diff --git a/Benchmarks/Benchmarks.hs b/Benchmarks/Benchmarks.hs deleted file mode 100644 --- a/Benchmarks/Benchmarks.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Main where - -import Certificate -import Control.Concurrent.Chan -import Data.Default (def) -import Data.IORef -import Data.X509 -import Data.X509.Validation -import Test.Tasty.Bench -import Network.TLS -import Network.TLS.Extra.Cipher -import Session -import Run -import PubKey - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -blockCipher :: Cipher -blockCipher = - Cipher - { cipherID = 0xff12 - , cipherName = "rsa-id-const" - , cipherBulk = - Bulk - { bulkName = "id" - , bulkKeySize = 16 - , bulkIVSize = 16 - , bulkExplicitIV = 0 - , bulkAuthTagLen = 0 - , bulkBlockSize = 16 - , bulkF = BulkBlockF $ \_ _ _ m -> (m, B.empty) - } - , cipherHash = MD5 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - -getParams :: Version -> Cipher -> (ClientParams, ServerParams) -getParams connectVer cipher = (cParams, sParams) - where - sParams = - def - { serverSupported = supported - , serverShared = - def - { sharedCredentials = - Credentials - [(CertificateChain [simpleX509 $ PubKeyRSA pubKey], PrivKeyRSA privKey)] - } - } - cParams = - (defaultParamsClient "" B.empty) - { clientSupported = supported - , clientShared = - def - { sharedValidationCache = - ValidationCache - { cacheAdd = \_ _ _ -> return () - , cacheQuery = \_ _ _ -> return ValidationCachePass - } - } - } - supported = - def - { supportedCiphers = [cipher] - , supportedVersions = [connectVer] - , supportedGroups = [X25519, FFDHE2048] - } - (pubKey, privKey) = getGlobalRSAPair - -runTLSPipe - :: (ClientParams, ServerParams) - -> (Context -> Chan b -> IO ()) - -> (Chan a -> Context -> IO ()) - -> a - -> IO b -runTLSPipe params tlsServer tlsClient d = do - withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do - writeStart d - readResult - -runTLSPipeSimple - :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString -runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient - where - tlsServer ctx queue = do - handshake ctx - d <- recvData ctx - writeChan queue d - bye ctx - tlsClient queue ctx = do - handshake ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - -benchConnection - :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark -benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d - -benchResumption - :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark -benchResumption params !d name = env initializeSession runResumption - where - initializeSession = do - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - params1 = setPairParamsSessionManagers sessionManagers params - _ <- runTLSPipeSimple params1 d - - Just sessionParams <- readClientSessionRef sessionRefs - let params2 = setPairParamsSessionResuming sessionParams params1 - newIORef params2 - - runResumption paramsRef = bench name . nfIO $ do - params2 <- readIORef paramsRef - runTLSPipeSimple params2 d - -benchResumption13 - :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark -benchResumption13 params !d name = env initializeSession runResumption - where - initializeSession = do - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - params1 = setPairParamsSessionManagers sessionManagers params - _ <- runTLSPipeSimple params1 d - newIORef (params1, sessionRefs) - - -- with TLS13 the sessionId is constantly changing so we must update - -- our parameters at each iteration unfortunately - runResumption paramsRef = bench name . nfIO $ do - (params1, sessionRefs) <- readIORef paramsRef - Just sessionParams <- readClientSessionRef sessionRefs - let params2 = setPairParamsSessionResuming sessionParams params1 - runTLSPipeSimple params2 d - -benchCiphers :: String -> Version -> B.ByteString -> [Cipher] -> Benchmark -benchCiphers name connectVer d = bgroup name . map doBench - where - doBench cipher = - benchResumption13 (getParams connectVer cipher) d (cipherName cipher) - -main :: IO () -main = - defaultMain - [ bgroup - "connection" - -- not sure the number actually make sense for anything. improve .. - [ benchConnection (getParams TLS12 blockCipher) small "TLS12-256 bytes" - ] - , bgroup - "resumption" - [ benchResumption (getParams TLS12 blockCipher) small "TLS12-256 bytes" - ] - , -- Here we try to measure TLS12 and TLS13 performance with AEAD ciphers. - -- Resumption and a larger message can be a demonstration of the symmetric - -- crypto but for TLS13 this does not work so well because of dhe_psk. - benchCiphers - "TLS12" - TLS12 - large - [ cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 - , cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 - , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 - , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 - , cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 - , cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 - ] - , benchCiphers - "TLS13" - TLS13 - large - [ cipher13_AES_128_GCM_SHA256 - , cipher13_AES_256_GCM_SHA384 - , cipher13_CHACHA20_POLY1305_SHA256 - , cipher13_AES_128_CCM_SHA256 - , cipher13_AES_128_CCM_8_SHA256 - ] - ] - where - small = B.replicate 256 0 - large = B.replicate 102400 0 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,295 @@ # Change log for "tls" +## Version 2.5.1 + +Sessions saved by 2.5.0 cannot be resumed: `SessionData` has a new field. + +* Keep application data in SessionData and let the server decide 0-RTT. + [#640](https://github.com/haskell-tls/hs-tls/pull/640) + +## Version 2.5.0 + +**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 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. + [#618](https://github.com/haskell-tls/hs-tls/pull/618) +* Check the second ClientHello after HelloRetryRequest. + [#619](https://github.com/haskell-tls/hs-tls/pull/619) +* Answer an empty cipher_suites or compression_methods with decode_error. + [#620](https://github.com/haskell-tls/hs-tls/pull/620) +* Refuse data after the content of an extension. + [#621](https://github.com/haskell-tls/hs-tls/pull/621) +* Answer a protected change_cipher_spec with unexpected_message. + [#622](https://github.com/haskell-tls/hs-tls/pull/622) +* Answer an unexpected post-handshake message with unexpected_message instead of dropping it. + [#623](https://github.com/haskell-tls/hs-tls/pull/623) +* Ignore the alert level in TLS 1.3: a warning-level error alert is an error, and a fatal-level close_notify is a closure. + [#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) +* 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 + +* Authenticate a server that rejects the PSK of 0-RTT. + [#590](https://github.com/haskell-tls/hs-tls/pull/590) +* Require the client Certificate a TLS 1.2 server asked for. + [#591](https://github.com/haskell-tls/hs-tls/pull/591) +* Refuse a TLS 1.3 alert in clear after the handshake. + [#592](https://github.com/haskell-tls/hs-tls/pull/592) +* Require Certificate and ServerKeyExchange from a TLS 1.2 server. + [#593](https://github.com/haskell-tls/hs-tls/pull/593) +* Refuse a TLS 1.2 ChangeCipherSpec before its keys exist. + [#594](https://github.com/haskell-tls/hs-tls/pull/594) +* Answer an unfit ServerKeyExchange algorithm with an alert. + [#595](https://github.com/haskell-tls/hs-tls/pull/595) + +## Version 2.4.11 + +* Keep preferring AES-GCM on AArch64 with crypton 2.2, which names the + ARMv8 instructions rather than x86's. + [#584](https://github.com/haskell-tls/hs-tls/pull/584) +* Sign and verify RSA PKCS#1 v1.5 through crypton's digest-taking + operations, which deprecate the ones used before. crypton >= 2.1.9 is + now required. + [#585](https://github.com/haskell-tls/hs-tls/pull/585) +* Remove the `tls-bench` benchmark. + +## Version 2.4.10 + +* Support ML-DSA certificates and CertificateVerify, TLS 1.3 only + (draft-ietf-tls-mldsa). + [#583](https://github.com/haskell-tls/hs-tls/pull/583) +* Take ML-KEM from `crypton` instead of the `mlkem` package. + [#583](https://github.com/haskell-tls/hs-tls/pull/583) +* `tls-server`: let `-g` choose the TLS 1.3 groups too. + [#583](https://github.com/haskell-tls/hs-tls/pull/583) + +## Version 2.4.9 + +* Include CertificateRequest in the post-handshake auth transcript. + This breaks PHA with hs-tls 2.4.8 or earlier. + [#565](https://github.com/haskell-tls/hs-tls/pull/565) +* Send a TLS 1.2 session ticket only to a client that asked for one. + [#575](https://github.com/haskell-tls/hs-tls/pull/575) +* Fall back to a full handshake when a PSK finds a TLS 1.2 session. + [#576](https://github.com/haskell-tls/hs-tls/pull/576) +* Refuse SCSV or a missing renegotiation_info in secure renegotiation. + [#566](https://github.com/haskell-tls/hs-tls/pull/566) +* Reject a hybrid key share whose classical part fails to derive. + [#550](https://github.com/haskell-tls/hs-tls/pull/550) +* Send no SNI for an empty server name, and refuse a malformed or + invalid server_name. + [#568](https://github.com/haskell-tls/hs-tls/pull/568) +* Refuse a CertificateVerify algorithm that is not offered or does not + fit the key with illegal_parameter. + [#562](https://github.com/haskell-tls/hs-tls/pull/562) + [#578](https://github.com/haskell-tls/hs-tls/pull/578) +* Accept an empty TLS 1.2 client certificate when the hook does. + [#552](https://github.com/haskell-tls/hs-tls/pull/552) +* Request EdDSA client certificates with ecdsa_sign in TLS 1.2. + [#553](https://github.com/haskell-tls/hs-tls/pull/553) +* Accept a ClientHello whose legacy_version is above TLS 1.2. + [#564](https://github.com/haskell-tls/hs-tls/pull/564) +* Answer malformed or misplaced messages with the alerts the RFCs ask for. + [#554](https://github.com/haskell-tls/hs-tls/pull/554) + [#555](https://github.com/haskell-tls/hs-tls/pull/555) + [#556](https://github.com/haskell-tls/hs-tls/pull/556) + [#557](https://github.com/haskell-tls/hs-tls/pull/557) + [#558](https://github.com/haskell-tls/hs-tls/pull/558) + [#559](https://github.com/haskell-tls/hs-tls/pull/559) + [#560](https://github.com/haskell-tls/hs-tls/pull/560) + [#561](https://github.com/haskell-tls/hs-tls/pull/561) + [#563](https://github.com/haskell-tls/hs-tls/pull/563) + [#567](https://github.com/haskell-tls/hs-tls/pull/567) + [#569](https://github.com/haskell-tls/hs-tls/pull/569) + [#570](https://github.com/haskell-tls/hs-tls/pull/570) + [#571](https://github.com/haskell-tls/hs-tls/pull/571) +* tls-server: new options for tlsfuzzer, which CI runs weekly. + [#551](https://github.com/haskell-tls/hs-tls/pull/551) + [#572](https://github.com/haskell-tls/hs-tls/pull/572) + [#573](https://github.com/haskell-tls/hs-tls/pull/573) + [#574](https://github.com/haskell-tls/hs-tls/pull/574) + [#577](https://github.com/haskell-tls/hs-tls/pull/577) + +## Version 2.4.8 + +* Stop printing traffic secrets and the session secret. + [#549](https://github.com/haskell-tls/hs-tls/pull/549) + +## Version 2.4.7 + +* Use the one-call AES-GCM and ChaCha20-Poly1305 interfaces of crypton. + This needs crypton 2.1.1 or later. + [#548](https://github.com/haskell-tls/hs-tls/pull/548) + +## Version 2.4.6 + +* Accept crypton 2.1. + +## Version 2.4.5 + +* Fix the TLS 1.3 0-RTT session tests racing the NewSessionTicket. + [#547](https://github.com/haskell-tls/hs-tls/pull/547) +* CI: drop macOS with GHC 9.12. + [#546](https://github.com/haskell-tls/hs-tls/pull/546) +* CI: retry Hackage downloads, keep the cache when a test fails, and run + doctest on one job. + [#545](https://github.com/haskell-tls/hs-tls/pull/545) +* `extensionDecode` returns `Nothing` instead of calling `error`. + [#544](https://github.com/haskell-tls/hs-tls/pull/544) +* `getTLSUnique` and `getTLSExporter` return `Nothing` before a handshake. + [#543](https://github.com/haskell-tls/hs-tls/pull/543) +* Take two timing signals out of the CBC record path. + [#542](https://github.com/haskell-tls/hs-tls/pull/542) +* Bound the size of a handshake message reassembled from records. + [#541](https://github.com/haskell-tls/hs-tls/pull/541) +* CI: speed up. + [#540](https://github.com/haskell-tls/hs-tls/pull/540) +* Limit consecutive TLS 1.3 KeyUpdate messages with the new + `limitKeyUpdate` parameter. + [#539](https://github.com/haskell-tls/hs-tls/pull/539) +* Validate the negotiated ALPN protocol. + [#538](https://github.com/haskell-tls/hs-tls/pull/538) +* Validate the negotiated cipher suite. + [#537](https://github.com/haskell-tls/hs-tls/pull/537) +* Make the session ticket tests deterministic. + [#536](https://github.com/haskell-tls/hs-tls/pull/536) + +## Version 2.4.4 + +* Enforce server certificate purpose + [#534](https://github.com/haskell-tls/hs-tls/pull/534) +* Use dedicated doctest REPL + [#533](https://github.com/haskell-tls/hs-tls/pull/533) +* Bind early data to ALPN + [#532](https://github.com/haskell-tls/hs-tls/pull/532) +* Bound certificate decompression + [#531](https://github.com/haskell-tls/hs-tls/pull/531) +* Fix RecordOverflow race after TLS 1.3 client authentication + [#530](https://github.com/haskell-tls/hs-tls/pull/530) + +## Version 2.4.3 + +* A server checks clientAuth of ExtendedKeyUsage in a client + certificate on client authentication. + +## Version 2.4.2 + +* The `Network.TLS.Extra.CipherCBC` module is added. + [#526](https://github.com/haskell-tls/hs-tls/pull/526) + +## Version 2.4.1 + +* Ensure same `supported_groups` before/after HRR. +* New `clientWantTicket` parameter makes it possible to opt-out of soliciting + session tickets from servers. + +## Version 2.4.0 + +* Identical to v2.3.1 but major version up as v2.3.1 breaks "quic". + +## Version 2.3.1 (deprecated) + +* Using ScrubbedBytes for secrets. +* Key echange with ML-KEM. + [#517](https://github.com/haskell-tls/hs-tls/pull/517) +* Expose get certificate chain function + [#520](https://github.com/haskell-tls/hs-tls/pull/520) + +## Version 2.3.0 + +* Using "ram" instead of "memory". + +## Version 2.2.2 + +* A new architecture to calculate receiver's transcript hash with wire + format. + [#515](https://github.com/haskell-tls/hs-tls/pull/515) +* Enabling compressed certificate on the client side again. + +## Version 2.2.1 + +* Disabling compressed certificate on the client side. + [#514](https://github.com/haskell-tls/hs-tls/issues/514) + +## Version 2.2.0 + +* Using crypton-asn1-* and time-hourglass. + [#512](https://github.com/haskell-tls/hs-tls/pull/512) +* Major version up due to re-exports. + ## Version 2.1.14 * Supporting P384 and P521 curves. @@ -51,14 +341,14 @@ This feature is automatically used if the peer supports it. * More tests with `tlsfuzzer` especially for client authentication and 0-RTT. -* Implementing a utility funcation, `validateClientCertificate`, for +* Implementing a utility function, `validateClientCertificate`, for client authentication. * Bug fix for echo back logic of Cookie extension. * More pretty show for the internal `Handshake` structure for debugging. ## Version 2.1.6 -* Testing with "tlsfuzzer" again. Now don't send an alert agaist to +* Testing with "tlsfuzzer" again. Now don't send an alert against to peer's alert. Double locking (aka self dead-lock) is fixed. Sending an alert for known-but-cannot-parse extensions. Other corner cases are also fixed. @@ -322,7 +612,7 @@ API CHANGES: - `SessionManager` implementations need to provide a `sessionResumeOnlyOnce` - function to accomodate resumption scenarios with 0-RTT data. The function is + function to accommodate resumption scenarios with 0-RTT data. The function is called only on the server side. - Data type `SessionData` is extended with four new fields for TLS version 1.3. `SessionManager` implementations that serializes/deserializes `SessionData` diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} -- | -- Native Haskell TLS protocol implementation for servers and -- clients. @@ -11,7 +12,7 @@ -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions. -- --- The tipical usage is: +-- The typical usage is: -- -- > socket <- ... -- > ctx <- contextNew socket @@ -25,6 +26,7 @@ handshake, sendData, recvData, + closeNotifyReceived, bye, -- * Exceptions @@ -46,6 +48,7 @@ clientUseServerNameIndication, clientWantSessionResume, clientWantSessionResumeList, + clientWantTicket, clientShared, clientHooks, clientSupported, @@ -88,6 +91,7 @@ onSuggestALPN, onCustomFFDHEGroup, onServerFinished, + onSelectKeyShareGroups, -- ** Server hooks ServerHooks, @@ -100,6 +104,8 @@ onNewHandshake, onALPNClientSuggest, onEncryptedExtensionsCreating, + onSelectKeyShare, + onAccept0RTT, Measurement, nbHandshakes, bytesReceived, @@ -110,6 +116,12 @@ defaultSupported, supportedVersions, supportedCiphers, + supportedMinRSAKeySize, + supportedMaxRSAKeySize, + supportedClientCertificatePurposes, + supportedMinDHKeySize, + supportedMaxDHKeySize, + supportedClientCipherOrder, supportedCompressions, supportedHashSignatures, supportedSecureRenegotiation, @@ -119,6 +131,7 @@ supportedFallbackScsv, supportedEmptyPacket, supportedGroups, + supportedGroupsTLS13, -- ** Debug parameters DebugParams, @@ -135,7 +148,9 @@ Limit, defaultLimit, limitHandshakeFragment, + limitKeyUpdate, limitRecordSize, + limitRecordsPerKey, -- * Shared parameters @@ -161,6 +176,7 @@ -- ** Session data SessionData, + defaultSessionData, sessionVersion, sessionCipher, sessionCompression, @@ -171,6 +187,8 @@ sessionALPN, sessionMaxEarlyDataSize, sessionFlags, + sessionClientCertificate, + sessionAppData, SessionFlag (..), TLS13TicketInfo, is0RTTPossible, @@ -189,10 +207,10 @@ Version (..), Compression (..), nullCompression, + SignatureScheme (..), HashAndSignatureAlgorithm, supportedSignatureSchemes, - HashAlgorithm (..), - SignatureAlgorithm (..), + signatureSchemesForTLS13, Group (..), supportedNamedGroups, EMSMode (..), @@ -230,12 +248,15 @@ infoTLS13HandshakeMode, infoIsEarlyDataAccepted, infoIsECHAccepted, + infoServerSignatureScheme, + infoClientSignatureScheme, ClientRandom, ServerRandom, unClientRandom, unServerRandom, HandshakeMode13 (..), getClientCertificateChain, + getServerCertificateChain, -- ** Negotiated getNegotiatedProtocol, @@ -245,6 +266,8 @@ updateKey, KeyUpdateRequest (..), requestCertificate, + requestCertificateAsync, + PHAResult (..), getTLSUnique, getTLSExporter, getTLSServerEndPoint, @@ -293,6 +316,7 @@ -- ** Crypto Key PubKey (..), PrivKey (..), + ExtKeyUsagePurpose (..), -- ** Ciphers & Predefined ciphers module Network.TLS.Cipher, @@ -305,7 +329,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 (..)) @@ -321,10 +345,10 @@ import Network.TLS.Crypto ( DHParams, DHPublic, - Group (..), KxError (..), supportedNamedGroups, ) +import Network.TLS.Extension import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks import Network.TLS.Imports @@ -337,14 +361,14 @@ CertificateType (..), ClientRandom (..), Handshake, - HashAlgorithm (..), + SignatureScheme (..), HashAndSignatureAlgorithm, Header (..), ProtocolType (..), ServerRandom (..), - SignatureAlgorithm (..), TLSError (..), TLSException (..), + signatureSchemesForTLS13, supportedSignatureSchemes, ) import Network.TLS.Struct13 (Handshake13) @@ -355,12 +379,14 @@ 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 + +getServerCertificateChain :: Context -> IO (Maybe CertificateChain) +getServerCertificateChain ctx = usingState_ ctx S.getServerCertificateChain -- $exceptions -- Since 1.8.0, this library only throws exceptions of type 'TLSException'. diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs --- a/Network/TLS/Compression.hs +++ b/Network/TLS/Compression.hs @@ -51,7 +51,7 @@ (==) c1 c2 = compressionID c1 == compressionID c2 -- | intersect a list of ids commonly given by the other side with a list of compression --- the function keeps the list of compression in order, to be able to find quickly the prefered +-- the function keeps the list of compression in order, to be able to find quickly the preferred -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -8,13 +8,16 @@ Context (..), Hooks (..), Established (..), + PendingRecv (..), RecordLayer (..), ctxEOF, + ctxCloseNotify, ctxEstablished, withLog, ctxWithHooks, contextModifyHooks, setEOF, + setCloseNotify, setEstablished, contextFlush, contextClose, @@ -23,6 +26,7 @@ updateMeasure, withMeasure, withReadLock, + tryWithReadLock, withWriteLock, withStateLock, withRWLock, @@ -72,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 @@ -83,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 @@ -112,9 +116,10 @@ getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO () - doHandshakeWith :: a -> Context -> Handshake -> IO () + doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool - doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () + doRequestCertificateAsync :: a -> Context -> IO (Bool -> IO PHAResult) + doPostHandshakeAuthWith :: a -> Context -> Handshake13R -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams = @@ -126,6 +131,7 @@ doHandshake = handshakeClient doHandshakeWith = handshakeClientWith doRequestCertificate _ _ = return False + doRequestCertificateAsync _ _ = return $ \_ -> return PHAUnavailable doPostHandshakeAuthWith = postHandshakeAuthClientWith instance TLSParams ServerParams where @@ -138,6 +144,7 @@ doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer + doRequestCertificateAsync = requestCertificateAsyncServer doPostHandshakeAuthWith = \_ _ _ -> return () -- | create a new context using the backend and parameters specified. @@ -166,6 +173,7 @@ tlsstate <- newMVar st eof <- newIORef False + closeNotify <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement needEmptyPacket <- newIORef False @@ -174,6 +182,7 @@ rx <- newMVar newRecordState hs <- newMVar Nothing recvActionsRef <- newIORef [] + appDataRef <- newIORef [] sendActionRef <- newIORef Nothing locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State @@ -185,6 +194,7 @@ { doHandshake_ = doHandshake params , doHandshakeWith_ = doHandshakeWith params , doRequestCertificate_ = doRequestCertificate params + , doRequestCertificateAsync_ = doRequestCertificateAsync params , doPostHandshakeAuthWith_ = doPostHandshakeAuthWith params } @@ -203,11 +213,13 @@ , ctxRoleParams = roleParams , ctxMeasurement = stats , ctxEOF_ = eof + , ctxCloseNotify_ = closeNotify , ctxEstablished_ = established , ctxNeedEmptyPacket = needEmptyPacket , ctxHooks = hooks , ctxLocks = locks , ctxPendingRecvActions = recvActionsRef + , ctxPendingAppData = appDataRef , ctxPendingSendAction = sendActionRef , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp @@ -265,8 +277,11 @@ -- and use the "tls-exporter" channel binding via 'getTLSExporter'. getTLSUnique :: Context -> IO (Maybe ByteString) getTLSUnique ctx = do - ver <- liftIO $ usingState_ ctx getVersion - if ver == TLS12 + -- Nothing rather than error before a version has been negotiated: this + -- can be called on a context whose handshake has not run, and it already + -- answers with Maybe. + mver <- liftIO $ usingState_ ctx getVersionMaybe + if mver == Just TLS12 then do mx <- usingState_ ctx getFirstVerifyData case mx of @@ -278,8 +293,9 @@ -- For TLS 1.2, 'Nothing' is returned. getTLSExporter :: Context -> IO (Maybe ByteString) getTLSExporter ctx = do - ver <- liftIO $ usingState_ ctx getVersion - if ver == TLS13 + -- As in 'getTLSUnique'. + mver <- liftIO $ usingState_ ctx getVersionMaybe + if mver == Just TLS13 then exporter ctx "EXPORTER-Channel-Binding" "" 32 else return Nothing @@ -290,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 @@ -17,17 +17,21 @@ Hooks (..), Limit (..), Established (..), + PendingRecv (..), PendingRecvAction (..), RecordLayer (..), Locks (..), RoleParams (..), ctxEOF, + ctxCloseNotify, ctxEstablished, withLog, ctxWithHooks, contextModifyHooks, setEOF, + setCloseNotify, setEstablished, + skipEarlyData, contextFlush, contextClose, contextSend, @@ -36,6 +40,7 @@ updateMeasure, withMeasure, withReadLock, + tryWithReadLock, withWriteLock, withStateLock, withRWLock, @@ -61,10 +66,13 @@ -- * Misc HandshakeSync (..), + PHAResult (..), TLS13State (..), defaultTLS13State, getTLS13State, modifyTLS13State, + incrementTLS13KeyUpdateCount, + resetTLS13KeyUpdateCount, CipherChoice (..), makeCipherChoice, @@ -86,8 +94,10 @@ ) where import Control.Concurrent.MVar -import Control.Exception (throwIO) +import qualified Control.Exception as E import Control.Monad.State.Strict +import Data.ByteArray (convert) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.IORef import Data.Tuple @@ -109,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 @@ -124,6 +135,8 @@ , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. + , ctxCloseNotify_ :: IORef Bool + -- ^ has close_notify been received or not. , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful. , ctxTxRecordState :: MVar RecordState @@ -139,6 +152,8 @@ , -- TLS 1.3 ctxTLS13State :: IORef TLS13State , ctxPendingRecvActions :: IORef [PendingRecvAction] + , ctxPendingAppData :: IORef [ByteString] + -- ^ TLS 1.2 application data received during renegotiation, newest first , ctxPendingSendAction :: IORef (Maybe (Context -> IO ())) -- ^ pending post handshake authentication requests , -- QUIC @@ -166,9 +181,10 @@ data RoleParams = RoleParams { doHandshake_ :: Context -> IO () - , doHandshakeWith_ :: Context -> Handshake -> IO () + , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool - , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO () + , doRequestCertificateAsync_ :: Context -> IO (Bool -> IO PHAResult) + , doPostHandshakeAuthWith_ :: Context -> Handshake13R -> IO () } data Locks = Locks @@ -185,7 +201,7 @@ { cVersion :: Version , cCipher :: Cipher , cHash :: Hash - , cZero :: ByteString + , cZero :: Secret } deriving (Show) @@ -193,15 +209,18 @@ makeCipherChoice ver cipher = CipherChoice ver cipher h zero where h = cipherHash cipher - zero = B.replicate (hashDigestSize h) 0 + zero = BA.replicate (hashDigestSize h) 0 data TLS13State = TLS13State { tls13stRecvNST :: Bool -- client + , tls13stKeyUpdateCount :: Int + , tls13stSentKeyUpdates :: Word64 + , tls13stKeyUpdateResponded :: Bool , tls13stSentClientCert :: Bool -- client , tls13stRecvSF :: Bool -- client , tls13stSentCF :: Bool -- client , tls13stRecvCF :: Bool -- server - , tls13stPendingRecvData :: Maybe ByteString -- client + , tls13stPendingRecv :: PendingRecv -- client , tls13stPendingSentData :: [ByteString] -> [ByteString] -- client , tls13stRTT :: Millisecond , tls13st0RTT :: Bool -- client @@ -209,20 +228,45 @@ , tls13stClientExtensions :: [ExtensionRaw] -- client , tls13stChoice :: ~CipherChoice -- client , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client - -- Actuall session id for TLS 1.2, random value for TLS 1.3 + -- Actual session id for TLS 1.2, random value for TLS 1.3 , tls13stSession :: Session , tls13stSentExtensions :: [ExtensionID] + , 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 { tls13stRecvNST = False + , tls13stKeyUpdateCount = 0 + , tls13stSentKeyUpdates = 0 + , tls13stKeyUpdateResponded = False , tls13stSentClientCert = False , tls13stRecvSF = False , tls13stSentCF = False , tls13stRecvCF = False - , tls13stPendingRecvData = Nothing + , tls13stPendingRecv = NoPendingRecv , tls13stPendingSentData = id , tls13stRTT = 0 , tls13st0RTT = False @@ -232,6 +276,8 @@ , tls13stHsKey = Nothing , tls13stSession = Session Nothing , tls13stSentExtensions = [] + , tls13stPHA = Nothing + , tls13stPHAResponding = False } getTLS13State :: Context -> IO TLS13State @@ -240,6 +286,16 @@ modifyTLS13State :: Context -> (TLS13State -> TLS13State) -> IO () modifyTLS13State Context{..} f = atomicModifyIORef' ctxTLS13State $ \st -> (f st, ()) +incrementTLS13KeyUpdateCount :: Context -> IO Int +incrementTLS13KeyUpdateCount Context{..} = + atomicModifyIORef' ctxTLS13State $ \st -> + let count = tls13stKeyUpdateCount st + 1 + in (st{tls13stKeyUpdateCount = count}, count) + +resetTLS13KeyUpdateCount :: Context -> IO () +resetTLS13KeyUpdateCount ctx = + modifyTLS13State ctx $ \st -> st{tls13stKeyUpdateCount = 0} + data HandshakeSync = HandshakeSync (Context -> ClientState -> IO ()) @@ -264,18 +320,29 @@ data Established = NotEstablished | EarlyDataAllowed Int -- server: remaining 0-RTT bytes allowed - | EarlyDataNotAllowed Int -- sever: remaining 0-RTT packets allowed to skip + | EarlyDataNotAllowed Int -- server: remaining 0-RTT bytes allowed to skip | EarlyDataSending | Established deriving (Eq, Show) +-- | Outcome of a read that was started on behalf of a caller who is no longer +-- waiting for it, held until the next receive hands it over. Reads cannot be +-- abandoned once started -- see 'Network.TLS.Core.handshake' -- so a reader that +-- outlives its caller leaves its result here instead. +data PendingRecv + = NoPendingRecv + | PendingRecvData ByteString + | PendingRecvError E.SomeException + data PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment. - -- The second bool is update transcript hash. - PendingRecvAction Bool Bool (Handshake13 -> IO ()) + PendingRecvAction Bool (Handshake13 -> IO ()) + | PendingRecvActionSelfUpdate Bool (Handshake13R -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment. - PendingRecvActionHash Bool (TranscriptHash -> Handshake13 -> IO ()) + PendingRecvActionHash + Bool + (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx) @@ -288,6 +355,12 @@ contextFlush = backendFlush . ctxBackend -- | A shortcut for 'backendClose . ctxBackend'. +-- +-- For a 'Network.Socket.Socket', this is 'Network.Socket.close', which +-- also wakes up threads blocked on the socket. If no thread is left on +-- it, call 'Network.TLS.bye' and then @unsafeClose@ (network 3.2.11 or +-- later) on the socket instead, or give 'Network.TLS.contextNew' a +-- 'Backend' whose 'backendClose' does so. contextClose :: Context -> IO () contextClose = backendClose . ctxBackend @@ -296,7 +369,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 @@ -306,8 +379,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 @@ -322,7 +398,7 @@ { infoVersion = v , infoCipher = c , infoCompression = comp - , infoMainSecret = ms + , infoMainSecret = convert <$> ms , infoExtendedMainSecret = ems , infoClientRandom = cr , infoServerRandom = sr @@ -331,6 +407,8 @@ , infoTLS13HandshakeMode = hm13 , infoIsEarlyDataAccepted = accepted , infoIsECHAccepted = ech + , infoServerSignatureScheme = ssig + , infoClientSignatureScheme = csig } _ -> return Nothing @@ -345,8 +423,18 @@ 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 + +setCloseNotify :: Context -> IO () +setCloseNotify ctx = writeIORef (ctxCloseNotify_ ctx) True + ctxEstablished :: Context -> IO Established ctxEstablished ctx = readIORef $ ctxEstablished_ ctx @@ -359,11 +447,29 @@ setEstablished :: Context -> Established -> IO () setEstablished ctx = writeIORef (ctxEstablished_ ctx) +-- | Skips a record of rejected early data, given its length on the wire, if +-- the server is skipping them. Going over what may be skipped is refused +-- with unexpected_message (RFC 9846 Section 4.2.10). +skipEarlyData :: Context -> Int -> IO Bool +skipEarlyData ctx len = do + established <- ctxEstablished ctx + case established of + EarlyDataNotAllowed n + | cost <= n -> do + setEstablished ctx $ EarlyDataNotAllowed (n - cost) + return True + | otherwise -> + throwCore $ Error_Protocol "too much early data to skip" UnexpectedMessage + _ -> return False + where + -- The AEAD tag and the inner content type are not early data. + cost = max 1 (len - 17) + withLog :: Context -> (Logging -> IO ()) -> IO () withLog ctx f = ctxWithHooks ctx (f . hookLogging) throwCore :: MonadIO m => TLSError -> m a -throwCore = liftIO . throwIO . Uncontextualized +throwCore = liftIO . E.throwIO . Uncontextualized failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a failOnEitherError f = do @@ -383,7 +489,7 @@ usingHState :: MonadIO m => Context -> HandshakeM a -> m a usingHState ctx f = liftIO $ modifyMVar (ctxHandshakeState ctx) $ \case - Nothing -> liftIO $ throwIO MissingHandshake + Nothing -> liftIO $ E.throwIO MissingHandshake Just st -> return $ swap (Just <$> runHandshake st f) getHState :: MonadIO m => Context -> m (Maybe HandshakeState) @@ -445,6 +551,26 @@ withReadLock :: Context -> IO a -> IO a withReadLock ctx f = withMVar (lockRead $ ctxLocks ctx) (const f) + +-- | Like 'withReadLock', but returns 'Nothing' immediately instead of waiting +-- when another thread already holds the read lock. +-- +-- The read lock is what keeps a single thread reading the connection at a time. +-- Records arrive length-prefixed, so two threads reading in parallel would each +-- take a piece of whatever record the other was in the middle of, and neither +-- would end up with a usable message. +-- +-- Use this instead of 'withReadLock' when the read is optional and skipping it +-- is better than waiting for the current reader, which may hold the lock for +-- arbitrarily long. 'bye' is the only such caller; see the note there. +tryWithReadLock :: Context -> IO a -> IO (Maybe a) +tryWithReadLock ctx f = E.bracket acquire release $ \mlock -> case mlock of + Nothing -> return Nothing + Just _ -> Just <$> f + where + lock = lockRead $ ctxLocks ctx + acquire = tryTakeMVar lock + release = mapM_ (putMVar lock) withWriteLock :: Context -> IO a -> IO a withWriteLock ctx f = withMVar (lockWrite $ ctxLocks ctx) (const f) diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -22,11 +22,16 @@ sendData, recvData, recvData', + closeNotifyReceived, updateKey, KeyUpdateRequest (..), requestCertificate, + requestCertificateAsync, + PHAResult (..), ) where +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad.State.Strict import qualified Data.ByteString as B @@ -36,6 +41,11 @@ import System.Timeout import Network.TLS.Context +import Network.TLS.Context.Internal ( + PHAResult (..), + incrementTLS13KeyUpdateCount, + resetTLS13KeyUpdateCount, + ) import Network.TLS.Extension import Network.TLS.Handshake import Network.TLS.Handshake.Common @@ -54,6 +64,8 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types ( + Bulk (..), + Cipher (..), HostName, Role (..), ) @@ -72,11 +84,39 @@ sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx when (role == ClientRole && tls13 && sentClientCert) $ do rtt <- getRTT ctx - -- This 'timeout' should work. - mdat <- timeout rtt $ recvData13 ctx - case mdat of - Nothing -> return () - Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat} + -- We are only willing to wait 'rtt' for the alert, but a receive + -- must not be abandoned once it has started. Records are read + -- length-prefixed and the record layer keeps no receive buffer, so + -- an aborted receive loses the bytes it has already taken off the + -- transport and leaves the stream positioned inside a record. + -- Every later read is then misframed, and the connection is dead + -- with a spurious protocol error. + -- + -- So the receive runs in its own thread and we stop waiting for it + -- rather than interrupting it. It holds the read lock, which keeps + -- it the only reader and makes the next receive wait for it to + -- finish; its outcome is left in 'tls13stPendingRecv' for that + -- receive to pick up. + done <- newEmptyMVar + void $ forkIO $ withReadLock ctx $ do + r <- E.try $ recvData13 ctx + modifyTLS13State ctx $ \st -> + st + { tls13stPendingRecv = case r of + Right dat -> PendingRecvData dat + Left err -> PendingRecvError err + } + putMVar done () + arrived <- timeout rtt $ takeMVar done + -- Still report the authentication failure from 'handshake' itself + -- whenever it did arrive in time. + when (isJust arrived) $ do + pending <- tls13stPendingRecv <$> getTLS13State ctx + case pending of + PendingRecvError err -> do + modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv} + E.throwIO err + _ -> return () rttFactor :: Int rttFactor = 3 @@ -118,7 +158,7 @@ recvNST <- chk unless recvNST $ do rtt <- getRTT ctx - void $ timeout rtt $ recvHS13 ctx chk + tryRecvHS13 rtt chk else do -- receiving Client Finished let chk = tls13stRecvCF <$> getTLS13State ctx @@ -127,8 +167,28 @@ -- no chance to measure RTT before receiving CF -- fixme: 1sec is good enough? let rtt = 1000000 - void $ timeout rtt $ recvHS13 ctx chk + tryRecvHS13 rtt chk bye_ ctx + where + -- Receiving these messages only improves the chances of a later session + -- resumption, so giving up on them costs nothing important. We give up in + -- two different situations, for two different reasons. + -- + -- First, we need the read lock, because only one thread at a time may read + -- the connection, but we take it only if it happens to be free. Another + -- thread can be sitting in 'recvData' waiting for data that never arrives, + -- or the receive that 'handshake' starts can still be running, and either + -- holds the read lock for as long as it lasts. Waiting for the lock would + -- therefore hang 'bye', and closing a connection that a reader is stuck on + -- is exactly what 'bye' is for, so we skip the receive in that case. + -- + -- Second, if we do get the lock, we wait 'rtt' for the message and then + -- abandon the receive. Abandoning it can stop the connection part way + -- through a record, after which nothing can be read from it again -- which + -- is acceptable only because we are closing the connection here anyway. + tryRecvHS13 :: Int -> IO Bool -> IO () + tryRecvHS13 rtt chk = + void $ tryWithReadLock ctx $ timeout rtt $ recvHS13 ctx chk bye_ :: MonadIO m => Context -> m () bye_ ctx = liftIO $ do @@ -174,7 +234,10 @@ 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} role <- usingState_ ctx getRole sentCF <- tls13stSentCF <$> getTLS13State ctx rtt0 <- tls13st0RTT <$> getTLS13State ctx @@ -188,11 +251,37 @@ -- All chunks are protected with the same write lock because we don't -- want to interleave writes from other threads in the middle of our -- possibly large write. - mlen <- getPeerRecordLimit ctx -- plaintext, dont' adjust for TLS 1.3 + mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3 mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) +-- 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. +-- ClientHello is received. An empty result means EOF. Use +-- 'closeNotifyReceived' to tell an orderly closure from a truncation. recvData :: MonadIO m => Context -> m ByteString recvData ctx = liftIO $ do tls13 <- tls13orLater ctx @@ -209,17 +298,19 @@ recvData12 :: Context -> IO ByteString recvData12 ctx = do - pkt <- recvPacket12 ctx - either (onError terminate12) process pkt + pending <- atomicModifyIORef' (ctxPendingAppData ctx) $ \xs -> ([], reverse xs) + if null pending + then recvPacket12 ctx >>= either (onError terminate12) process + else return $ B.concat pending where - process (Handshake [ch@ClientHello{}]) = - handshakeWith ctx ch >> recvData12 ctx - process (Handshake [hr@HelloRequest]) = - handshakeWith ctx hr >> recvData12 ctx + process (Handshake [ch@ClientHello{}] [b]) = + handshakeWith ctx (ch, b) >> recvData12 ctx + process (Handshake [hr@HelloRequest] [b]) = + handshakeWith ctx (hr, b) >> recvData12 ctx -- UserCanceled should be followed by a close_notify. -- fixme: is it safe to call recvData12? process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty - process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty + process (Alert [(AlertLevel_Warning, CloseNotify)]) = setCloseNotify ctx >> tryBye ctx >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx E.throwIO @@ -240,19 +331,36 @@ recvData13 :: Context -> IO ByteString recvData13 ctx = do - mdat <- tls13stPendingRecvData <$> getTLS13State ctx - case mdat of - Nothing -> do + pending <- tls13stPendingRecv <$> getTLS13State ctx + case pending of + NoPendingRecv -> do pkt <- recvPacket13 ctx either (onError (terminate13 ctx)) process pkt - Just dat -> do - modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing} + PendingRecvData dat -> do + clearPending return dat + PendingRecvError err -> do + clearPending + E.throwIO err 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. - process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty - process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty - process (Alert13 [(AlertLevel_Fatal, desc)]) = do + process (Alert13 [(_, UserCanceled)]) = return B.empty + process (Alert13 [(_, CloseNotify)]) = setCloseNotify ctx >> tryBye ctx >> setEOF ctx >> return B.empty + process (Alert13 [(_, desc)]) = do setEOF ctx E.throwIO ( Terminated @@ -260,12 +368,13 @@ ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc) ) - process (Handshake13 hs) = do - loopHandshake13 hs + process (Handshake13 hs bs) = do + loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. - process (AppData13 "") = recvData13 ctx + process (AppData13 "") = checkPHAResponse >> recvData13 ctx process (AppData13 x) = do + checkPHAResponse let chunkLen = C8.length x established <- ctxEstablished ctx case established of @@ -276,14 +385,7 @@ | otherwise -> let reason = "early data overflow" in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - EarlyDataNotAllowed n - | n > 0 -> do - setEstablished ctx $ EarlyDataNotAllowed (n - 1) - recvData13 ctx -- ignore "x" - | otherwise -> do - let reason = "early data deprotect overflow" - terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - Established -> return x + Established -> resetTLS13KeyUpdateCount ctx >> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do established <- ctxEstablished ctx @@ -299,7 +401,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. - loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do + loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only" @@ -328,16 +430,20 @@ let ticket' = B.copy ticket void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} - loopHandshake13 hs - loopHandshake13 (KeyUpdate13 mode : hs) = do - let multipleKeyUpdate = any isKeyUpdate13 hs - when multipleKeyUpdate $ do - let reason = "Multiple KeyUpdate is not allowed in one record" - terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + 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 - checkAlignment ctx hs + aligned <- isAligned ctx hbs + unless aligned $ + terminate13 + ctx + (Error_Misc notAligned) + AlertLevel_Fatal + UnexpectedMessage + notAligned established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal. @@ -345,21 +451,34 @@ -- to key update (update_requested) which we sent. if established == Established then do + case limitKeyUpdate $ sharedLimit $ ctxShared ctx of + Just limit | limit > 0 -> do + count <- incrementTLS13KeyUpdateCount ctx + when (count > limit) $ do + let reason = "too many consecutive KeyUpdate messages" + terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + _ -> return () keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. - when (mode == UpdateRequested) $ withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] - keyUpdate ctx getTxRecordState setTxRecordState - loopHandshake13 hs + when (mode == UpdateRequested) $ + withWriteLock ctx $ + respondToKeyUpdate ctx + loopHandshake13 hbs else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - -- Client only - loopHandshake13 (h@CertRequest13{} : hs) = - postHandshakeAuthWith ctx h >> loopHandshake13 hs - loopHandshake13 (h : hs) = do + -- Client only. Before Established, it belongs to the handshake that + -- 0-RTT left to the pending actions. + loopHandshake13 (hb@(CertRequest13{}, _) : hbs) = do + established <- ctxEstablished ctx + if established == Established + then postHandshakeAuthWith ctx hb >> loopHandshake13 hbs + else loopPending hb hbs + loopHandshake13 (hb : hbs) = loopPending hb hbs + + loopPending hb@(h, _) hbs = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of ServerHello13 SH{..} -> @@ -368,8 +487,8 @@ let reason = "HRR is not allowed for 0-RTT" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return () - cont <- popAction ctx h hs - when cont $ loopHandshake13 hs + popAction ctx hb hbs + loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do @@ -378,10 +497,11 @@ either (\_ -> return ()) process pkt where -- UserCanceled MUST be followed by a CloseNotify. - process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx - process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx - process (Handshake13 hs) = do - loopHandshake13 hs + process (Alert13 [(_, UserCanceled)]) = recvHS13 ctx breakLoop + process (Alert13 [(_, CloseNotify)]) = setCloseNotify ctx >> tryBye ctx >> setEOF ctx + process (Alert13 [(_, _desc)]) = setEOF ctx + process (Handshake13 hs bs) = do + loopHandshake13 $ zip hs bs stop <- breakLoop unless stop $ recvHS13 ctx breakLoop process _ = recvHS13 ctx breakLoop @@ -389,7 +509,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. - loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do + loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only" @@ -415,49 +535,65 @@ let ticket' = B.copy ticket void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} - loopHandshake13 hs - loopHandshake13 (h : hs) = do - cont <- popAction ctx h hs - when cont $ loopHandshake13 hs + loopHandshake13 hbs + loopHandshake13 (hb : hbs) = do + popAction ctx hb hbs + loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool -popAction ctx h hs = do +popAction :: Context -> Handshake13R -> [Handshake13R] -> IO () +popAction ctx hb@(h, _b) hbs = do mPendingRecvAction <- popPendingRecvAction ctx case mPendingRecvAction of - Nothing -> return False + -- RFC 9846 Section 6.2: a message no pending action expects is + -- unexpected_message, not dropped. + Nothing -> do + let reason = "unexpected handshake message " ++ show h + 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 update pa -> do - when needAligned $ checkAlignment ctx hs - when update $ void $ updateTranscriptHash13 ctx h - pa h - PendingRecvActionHash needAligned pa -> do - when needAligned $ checkAlignment ctx hs - d <- transcriptHash ctx "Pending action" - void $ updateTranscriptHash13 ctx h - 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 - return True + -- 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 + aligned <- isAligned ctx hbs + unless aligned $ throwCore $ Error_Protocol notAligned UnexpectedMessage -checkAlignment :: Context -> [Handshake13] -> IO () -checkAlignment ctx _hs = do +-- RFC 9846 Section 5.1: a message before a key change must end its +-- record, so neither a message nor a fragment may follow it. +isAligned :: Context -> [Handshake13R] -> IO Bool +isAligned ctx hbs = do complete <- isRecvComplete ctx - unless complete $ do - let reason = "received message not aligned with record boundary" - terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + return $ complete && null hbs +notAligned :: String +notAligned = "received message not aligned with record boundary" + -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions tryBye :: Context -> IO () @@ -501,6 +637,14 @@ setEOF ctx debugError (ctxDebug ctx) reason E.throwIO (Terminated False reason err) + +-- | Whether the peer has sent close_notify. If 'recvData' returns an +-- empty result and this is 'False', the transport was closed without +-- close_notify, so the data received may be truncated. +-- +-- @since 2.5.0 +closeNotifyReceived :: MonadIO m => Context -> m Bool +closeNotifyReceived = liftIO . ctxCloseNotify {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -145,33 +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/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -7,6 +7,7 @@ HashCtx, hashInit, hashUpdate, + hashUpdates, hashUpdateSSL, hashFinal, module Network.TLS.Crypto.DH, @@ -53,14 +54,16 @@ import qualified Crypto.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.MLDSA as MLDSA import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random -import Data.ASN1.BinaryEncoding (BER (..), DER (..)) +import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types -import qualified Data.ByteArray as B (convert) +import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Proxy import Data.X509 ( @@ -69,6 +72,7 @@ PubKey (..), PubKeyEC (..), SerializedPoint (..), + privkeyMLDSA_key, ) import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint) @@ -77,6 +81,8 @@ import Network.TLS.Crypto.Types import Network.TLS.Imports +---------------------------------------------------------------- + {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-} @@ -160,9 +166,9 @@ HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) hashFinal :: HashCtx -> ByteString -hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h +hashFinal (HashContext (ContextSimple h)) = convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) = - B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)] + B.concat [convert (H.hashFinalize md5Ctx), convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 deriving (Show, Eq) @@ -179,20 +185,14 @@ type HashCtx = HashContext -hash :: Hash -> ByteString -> ByteString -hash MD5 b = B.convert . (H.hash :: ByteString -> H.Digest H.MD5) $ b -hash SHA1 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA1) $ b -hash SHA224 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA224) $ b -hash SHA256 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA256) $ b -hash SHA384 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA384) $ b -hash SHA512 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA512) $ b -hash SHA1_MD5 b = - B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)] - where - sha1Hash :: ByteString -> H.Digest H.SHA1 - sha1Hash = H.hash - md5Hash :: ByteString -> H.Digest H.MD5 - md5Hash = H.hash +hash :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba +hash MD5 b = convert (H.hash b :: H.Digest H.MD5) +hash SHA1 b = convert (H.hash b :: H.Digest H.SHA1) +hash SHA224 b = convert (H.hash b :: H.Digest H.SHA224) +hash SHA256 b = convert (H.hash b :: H.Digest H.SHA256) +hash SHA384 b = convert (H.hash b :: H.Digest H.SHA384) +hash SHA512 b = convert (H.hash b :: H.Digest H.SHA512) +hash SHA1_MD5 b = BA.concat [hash MD5 b, hash SHA1 b] hashName :: Hash -> String hashName = show @@ -223,12 +223,12 @@ generalizeRSAError (Right x) = Right x kxEncrypt - :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString) + :: MonadRandom r => PublicKey -> ScrubbedBytes -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt - :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) + :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ScrubbedBytes) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) @@ -263,6 +263,13 @@ | ECDSAParams Hash | Ed25519Params | Ed448Params + | -- | Pure ML-DSA with an empty context, which is what + -- draft-ietf-tls-mldsa uses. One constructor per parameter set, + -- since the key fixes it and a signature made under one does not + -- verify under another. + MLDSA44Params + | MLDSA65Params + | MLDSA87Params deriving (Show, Eq) -- Verify that the signature matches the given message, using the @@ -273,38 +280,21 @@ kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign kxVerify (PubKeyDSA pk) DSAParams msg signBS = - case dsaToSignature signBS of - Just sig -> DSA.verify H.SHA1 pk sig msg + case decodeSignatureRS signBS of + Just (r, s) -> DSA.verify H.SHA1 pk DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} msg _ -> False - where - dsaToSignature :: ByteString -> Maybe DSA.Signature - dsaToSignature b = - case decodeASN1' BER b of - Left _ -> Nothing - Right asn1 -> - case asn1 of - Start Sequence : IntVal r : IntVal s : End Sequence : _ -> - Just DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} - _ -> - Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ join $ withPubKeyEC key verifyProxy verifyClassic Nothing where - decodeSignatureASN1 buildRS = - case decodeASN1' BER sigBS of - Left _ -> Nothing - Right [Start Sequence, IntVal r, IntVal s, End Sequence] -> - Just (buildRS r s) - Right _ -> Nothing verifyProxy prx pubkey = do - rs <- decodeSignatureASN1 (,) + rs <- decodeSignatureRS sigBS signature <- maybeCryptoError $ ECDSA.signatureFromIntegers prx rs verifyF <- withAlg (ECDSA.verify prx) return $ verifyF pubkey signature msg verifyClassic pubkey = do - signature <- decodeSignatureASN1 ECDSA_ECC.Signature + signature <- uncurry ECDSA_ECC.Signature <$> decodeSignatureRS sigBS verifyF <- withAlg ECDSA_ECC.verify return $ verifyF pubkey signature msg withAlg :: (forall hash. H.HashAlgorithm hash => hash -> a) -> Maybe a @@ -324,8 +314,66 @@ case Ed448.signature sigBS of CryptoPassed sig -> Ed448.verify key msg sig _ -> False +-- A signature of the wrong length is refused by the smart constructor, and +-- one of the right length that does not verify returns False. Neither +-- throws, which is what a peer sending a damaged CertificateVerify has to +-- meet with decrypt_error rather than with a crash. +kxVerify (PubKeyMLDSA44 key) MLDSA44Params msg sigBS = mldsaVerify key msg sigBS +kxVerify (PubKeyMLDSA65 key) MLDSA65Params msg sigBS = mldsaVerify key msg sigBS +kxVerify (PubKeyMLDSA87 key) MLDSA87Params msg sigBS = mldsaVerify key msg sigBS kxVerify _ _ _ _ = False +mldsaVerify + :: MLDSA.MLDSA p + => MLDSA.VerificationKey p -> ByteString -> ByteString -> Bool +mldsaVerify key msg sigBS = case MLDSA.signature sigBS of + CryptoPassed sig -> MLDSA.verify key MLDSA.emptyContext msg sig + _ -> False + +-- | Decode a DSA or ECDSA signature: a DER SEQUENCE of two INTEGERs, r +-- and s (RFC 3279 Sections 2.2.2 and 2.2.3). This is done here rather +-- than with crypton-asn1-encoding, whose 'decodeASN1'' throws on some +-- malformed input rather than returning 'Left'. Only DER is accepted: +-- definite lengths in their shortest form, non-negative INTEGERs in +-- theirs, and nothing after the SEQUENCE. +decodeSignatureRS :: ByteString -> Maybe (Integer, Integer) +decodeSignatureRS bs = do + (0x30, body) <- whole bs + (0x02, rbs, rest) <- tlv body + (0x02, sbs) <- whole rest + (,) <$> derInteger rbs <*> derInteger sbs + where + whole b = do + (t, v, rest) <- tlv b + guard $ B.null rest + return (t, v) + tlv b = do + (t, b1) <- B.uncons b + (l0, b2) <- B.uncons b1 + (len, b3) <- case l0 of + _ | l0 < 0x80 -> Just (fromIntegral l0, b2) + 0x81 -> do + (l1, b3) <- B.uncons b2 + guard $ l1 >= 0x80 + Just (fromIntegral l1, b3) + 0x82 -> do + (l1, b3) <- B.uncons b2 + (l2, b4) <- B.uncons b3 + let n = fromIntegral l1 * 256 + fromIntegral l2 :: Int + guard $ n >= 0x100 + Just (n, b4) + _ -> Nothing + guard $ B.length b3 >= len + let (v, rest) = B.splitAt len b3 + return (t, v, rest) + derInteger v = do + (h, t) <- B.uncons v + guard $ h < 0x80 + case B.uncons t of + Just (h2, _) | h == 0 -> guard $ h2 >= 0x80 + _ -> return () + return $ B.foldl' (\acc w -> acc * 256 + fromIntegral w) 0 v + -- Sign the given message using the private key. -- kxSign @@ -365,9 +413,15 @@ Just sign -> Right (ECDSA.signatureToIntegers prx sign) unsupported = return $ Left KxUnsupported kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg = - return $ Right $ B.convert $ Ed25519.sign pk pub msg + return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg = - return $ Right $ B.convert $ Ed448.sign pk pub msg + return $ Right $ convert $ Ed448.sign pk pub msg +kxSign (PrivKeyMLDSA44 pk) (PubKeyMLDSA44 _) MLDSA44Params msg = + Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg +kxSign (PrivKeyMLDSA65 pk) (PubKeyMLDSA65 _) MLDSA65Params msg = + Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg +kxSign (PrivKeyMLDSA87 pk) (PubKeyMLDSA87 _) MLDSA87Params msg = + Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg kxSign _ _ _ _ = return (Left KxUnsupported) @@ -377,13 +431,17 @@ -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) -rsaSignHash SHA1_MD5 pk msg = RSA.signSafer noHash pk msg -rsaSignHash MD5 pk msg = RSA.signSafer (Just H.MD5) pk msg -rsaSignHash SHA1 pk msg = RSA.signSafer (Just H.SHA1) pk msg -rsaSignHash SHA224 pk msg = RSA.signSafer (Just H.SHA224) pk msg -rsaSignHash SHA256 pk msg = RSA.signSafer (Just H.SHA256) pk msg -rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg -rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg +-- SHA1_MD5 arrives already digested -- see buildVerifyData -- and what it +-- carries is MD5 ++ SHA1 with no ASN.1 around it, which is what TLS before +-- 1.2 signs. That is the DigestInfo case: nothing here hashes or encodes. +-- The rest are handed the message and hash it on the way, as signSafer did. +rsaSignHash SHA1_MD5 pk msg = RSA.signSaferDigestInfo pk msg +rsaSignHash MD5 pk msg = RSA.signSaferDigest pk (H.hashWith H.MD5 msg) +rsaSignHash SHA1 pk msg = RSA.signSaferDigest pk (H.hashWith H.SHA1 msg) +rsaSignHash SHA224 pk msg = RSA.signSaferDigest pk (H.hashWith H.SHA224 msg) +rsaSignHash SHA256 pk msg = RSA.signSaferDigest pk (H.hashWith H.SHA256 msg) +rsaSignHash SHA384 pk msg = RSA.signSaferDigest pk (H.hashWith H.SHA384 msg) +rsaSignHash SHA512 pk msg = RSA.signSaferDigest pk (H.hashWith H.SHA512 msg) rsapssSignHash :: MonadRandom m @@ -397,22 +455,19 @@ rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash" rsaVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool -rsaVerifyHash SHA1_MD5 = RSA.verify noHash -rsaVerifyHash MD5 = RSA.verify (Just H.MD5) -rsaVerifyHash SHA1 = RSA.verify (Just H.SHA1) -rsaVerifyHash SHA224 = RSA.verify (Just H.SHA224) -rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256) -rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384) -rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512) +rsaVerifyHash SHA1_MD5 pk msg = RSA.verifyDigestInfo pk msg +rsaVerifyHash MD5 pk msg = RSA.verifyDigest pk (H.hashWith H.MD5 msg) +rsaVerifyHash SHA1 pk msg = RSA.verifyDigest pk (H.hashWith H.SHA1 msg) +rsaVerifyHash SHA224 pk msg = RSA.verifyDigest pk (H.hashWith H.SHA224 msg) +rsaVerifyHash SHA256 pk msg = RSA.verifyDigest pk (H.hashWith H.SHA256 msg) +rsaVerifyHash SHA384 pk msg = RSA.verifyDigest pk (H.hashWith H.SHA384 msg) +rsaVerifyHash SHA512 pk msg = RSA.verifyDigest pk (H.hashWith H.SHA512 msg) rsapssVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsapssVerifyHash SHA256 = PSS.verify (PSS.defaultPSSParams H.SHA256) rsapssVerifyHash SHA384 = PSS.verify (PSS.defaultPSSParams H.SHA384) rsapssVerifyHash SHA512 = PSS.verify (PSS.defaultPSSParams H.SHA512) rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" - -noHash :: Maybe H.MD5 -noHash = Nothing ecdsaSignHash :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve) diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs --- a/Network/TLS/Crypto/DH.hs +++ b/Network/TLS/Crypto/DH.hs @@ -21,14 +21,15 @@ import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH -import qualified Data.ByteArray as B +import Data.ByteArray (ScrubbedBytes) +import qualified Data.ByteArray as BA import Network.TLS.RNG type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params -type DHKey = DH.SharedKey +type DHKey = ScrubbedBytes dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber @@ -46,12 +47,12 @@ return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey -dhGetShared params priv pub = - stripLeadingZeros (DH.getShared params priv pub) +dhGetShared params priv pub = stripLeadingZeros sec where + DH.SharedKey sec = DH.getShared params priv pub -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3. - stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb) + stripLeadingZeros sb = snd $ BA.span (== 0) sb -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1. diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs --- a/Network/TLS/Crypto/IES.hs +++ b/Network/TLS/Crypto/IES.hs @@ -1,4 +1,5 @@ -- | (Elliptic Curve) Integrated Encryption Scheme +-- KEM(Key Encapsulation Mechanism) based APIs -- -- Module : Network.TLS.Crypto.IES -- License : BSD-style @@ -6,16 +7,19 @@ -- Stability : experimental -- Portability : unknown module Network.TLS.Crypto.IES ( - GroupPublic, + GroupPublicA, + GroupPublicB, GroupPrivate, GroupKey, -- * Group methods groupGenerateKeyPair, - groupGetPubShared, - groupGetShared, - encodeGroupPublic, - decodeGroupPublic, + groupEncapsulate, + groupDecapsulate, + groupEncodePublicA, + groupDecodePublicA, + groupEncodePublicB, + groupDecodePublicB, -- * Compatibility with 'Network.TLS.Crypto.DH' dhParamsForGroup, @@ -24,12 +28,16 @@ ) where import Control.Arrow -import Crypto.ECC +import Crypto.ECC as ECC import Crypto.Error import Crypto.Number.Generate -import Crypto.PubKey.DH hiding (generateParams) +import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..)) +import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES -import qualified Data.ByteArray as B +import Crypto.PubKey.MLKEM (MLKEM1024, MLKEM512, MLKEM768) +import qualified Crypto.PubKey.MLKEM as ML +import Data.ByteArray (ScrubbedBytes, convert) +import qualified Data.ByteArray as BA import Data.Proxy import Network.TLS.Crypto.Types @@ -38,6 +46,7 @@ import Network.TLS.RNG import Network.TLS.Util.Serialization (i2ospOf_, os2ip) +{- FOURMOLU_DISABLE -} data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) | GroupPri_P384 (Scalar Curve_P384R1) @@ -49,23 +58,59 @@ | GroupPri_FFDHE4096 PrivateNumber | GroupPri_FFDHE6144 PrivateNumber | GroupPri_FFDHE8192 PrivateNumber + | GroupPri_MLKEM512 (ML.DecapsulationKey MLKEM512) + | GroupPri_MLKEM768 (ML.DecapsulationKey MLKEM768) + | GroupPri_MLKEM1024 (ML.DecapsulationKey MLKEM1024) + | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey MLKEM768) + | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey MLKEM768) + | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey MLKEM1024) deriving (Eq, Show) +{- FOURMOLU_ENABLE -} -data GroupPublic - = GroupPub_P256 (Point Curve_P256R1) - | GroupPub_P384 (Point Curve_P384R1) - | GroupPub_P521 (Point Curve_P521R1) - | GroupPub_X255 (Point Curve_X25519) - | GroupPub_X448 (Point Curve_X448) - | GroupPub_FFDHE2048 PublicNumber - | GroupPub_FFDHE3072 PublicNumber - | GroupPub_FFDHE4096 PublicNumber - | GroupPub_FFDHE6144 PublicNumber - | GroupPub_FFDHE8192 PublicNumber +{- FOURMOLU_DISABLE -} +data GroupPublicA + = GroupPubA_P256 (Point Curve_P256R1) + | GroupPubA_P384 (Point Curve_P384R1) + | GroupPubA_P521 (Point Curve_P521R1) + | GroupPubA_X255 (Point Curve_X25519) + | GroupPubA_X448 (Point Curve_X448) + | GroupPubA_FFDHE2048 PublicNumber + | GroupPubA_FFDHE3072 PublicNumber + | GroupPubA_FFDHE4096 PublicNumber + | GroupPubA_FFDHE6144 PublicNumber + | GroupPubA_FFDHE8192 PublicNumber + | GroupPubA_MLKEM512 (ML.EncapsulationKey MLKEM512) + | GroupPubA_MLKEM768 (ML.EncapsulationKey MLKEM768) + | GroupPubA_MLKEM1024 (ML.EncapsulationKey MLKEM1024) + | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey MLKEM768) + | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey MLKEM768) + | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey MLKEM1024) deriving (Eq, Show) +{- FOURMOLU_ENABLE -} -type GroupKey = SharedSecret +{- FOURMOLU_DISABLE -} +data GroupPublicB + = GroupPubB_P256 (Point Curve_P256R1) + | GroupPubB_P384 (Point Curve_P384R1) + | GroupPubB_P521 (Point Curve_P521R1) + | GroupPubB_X255 (Point Curve_X25519) + | GroupPubB_X448 (Point Curve_X448) + | GroupPubB_FFDHE2048 PublicNumber + | GroupPubB_FFDHE3072 PublicNumber + | GroupPubB_FFDHE4096 PublicNumber + | GroupPubB_FFDHE6144 PublicNumber + | GroupPubB_FFDHE8192 PublicNumber + | GroupPubB_MLKEM512 (ML.Ciphertext MLKEM512) + | GroupPubB_MLKEM768 (ML.Ciphertext MLKEM768) + | GroupPubB_MLKEM1024 (ML.Ciphertext MLKEM1024) + | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext MLKEM768) + | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext MLKEM768) + | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext MLKEM1024) + deriving (Eq, Show) +{- FOURMOLU_ENABLE -} +type GroupKey = ScrubbedBytes + p256 :: Proxy Curve_P256R1 p256 = Proxy @@ -81,7 +126,30 @@ x448 :: Proxy Curve_X448 x448 = Proxy -dhParamsForGroup :: Group -> Maybe Params +mlkem512 :: Proxy MLKEM512 +mlkem512 = Proxy + +-- crypton reports a value it will not accept as a 'CryptoFailable' and has a +-- constructor per type rather than one overloaded 'decode'. These two keep +-- the call sites below in the shape they were. +-- +-- 'ML.encapsulationKey' is the stricter of the two: besides the length it +-- runs the check of FIPS 203 section 7.2, so an encapsulation key whose +-- coefficients are out of range is refused here rather than used. +decodeEK + :: ML.MLKEM p => proxy p -> ByteString -> Maybe (ML.EncapsulationKey p) +decodeEK _ = maybeCryptoError . ML.encapsulationKey + +decodeCT :: ML.MLKEM p => proxy p -> ByteString -> Maybe (ML.Ciphertext p) +decodeCT _ = maybeCryptoError . ML.ciphertext + +mlkem768 :: Proxy MLKEM768 +mlkem768 = Proxy + +mlkem1024 :: Proxy MLKEM1024 +mlkem1024 = Proxy + +dhParamsForGroup :: Group -> Maybe DH.Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096 @@ -89,26 +157,47 @@ dhParamsForGroup FFDHE8192 = Just ffdhe8192 dhParamsForGroup _ = Nothing -groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic) +groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublicA) groupGenerateKeyPair P256 = - (GroupPri_P256, GroupPub_P256) `fs` curveGenerateKeyPair p256 + (GroupPri_P256, GroupPubA_P256) `fs` curveGenerateKeyPair p256 groupGenerateKeyPair P384 = - (GroupPri_P384, GroupPub_P384) `fs` curveGenerateKeyPair p384 + (GroupPri_P384, GroupPubA_P384) `fs` curveGenerateKeyPair p384 groupGenerateKeyPair P521 = - (GroupPri_P521, GroupPub_P521) `fs` curveGenerateKeyPair p521 + (GroupPri_P521, GroupPubA_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 = - (GroupPri_X255, GroupPub_X255) `fs` curveGenerateKeyPair x25519 + (GroupPri_X255, GroupPubA_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 = - (GroupPri_X448, GroupPub_X448) `fs` curveGenerateKeyPair x448 -groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048 -groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072 -groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096 -groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144 -groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192 + (GroupPri_X448, GroupPubA_X448) `fs` curveGenerateKeyPair x448 +groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPubA_FFDHE2048 +groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPubA_FFDHE3072 +groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPubA_FFDHE4096 +groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPubA_FFDHE6144 +groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPubA_FFDHE8192 +groupGenerateKeyPair MLKEM512 = do + (e, d) <- ML.generateKeyPair mlkem512 + return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e) +groupGenerateKeyPair MLKEM768 = do + (e, d) <- ML.generateKeyPair mlkem768 + return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e) +groupGenerateKeyPair MLKEM1024 = do + (e, d) <- ML.generateKeyPair mlkem1024 + return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e) +groupGenerateKeyPair X25519MLKEM768 = do + (d1, e1) <- fs' $ curveGenerateKeyPair x25519 + (e2, d2) <- ML.generateKeyPair mlkem768 + return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2)) +groupGenerateKeyPair P256MLKEM768 = do + (d1, e1) <- fs' $ curveGenerateKeyPair p256 + (e2, d2) <- ML.generateKeyPair mlkem768 + return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2)) +groupGenerateKeyPair P384MLKEM1024 = do + (d1, e1) <- fs' $ curveGenerateKeyPair p384 + (e2, d2) <- ML.generateKeyPair mlkem1024 + return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair" dhGroupGenerateKeyPair - :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber) + :: MonadRandom r => Group -> r (DH.Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096) @@ -116,148 +205,346 @@ dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) -addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b) +addParams :: Functor f => DH.Params -> f (a, b) -> f (DH.Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b) fs :: MonadRandom r - => (Scalar a -> GroupPrivate, Point a -> GroupPublic) + => (Scalar a -> GroupPrivate, Point a -> GroupPublicA) -> r (KeyPair a) - -> r (GroupPrivate, GroupPublic) + -> r (GroupPrivate, GroupPublicA) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) +fs' :: Monad m => m (KeyPair curve) -> m (Scalar curve, Point curve) +fs' action = do + keypair <- action + let pub = keypairGetPublic keypair + pri = keypairGetPrivate keypair + return (pri, pub) + gen :: MonadRandom r - => Params + => DH.Params -> Int -> (PrivateNumber -> GroupPrivate) - -> (PublicNumber -> GroupPublic) - -> r (GroupPrivate, GroupPublic) + -> (PublicNumber -> GroupPublicA) + -> r (GroupPrivate, GroupPublicA) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits gen' :: MonadRandom r - => Params + => DH.Params -> Int -> r (PrivateNumber, PublicNumber) -gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits +gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits -groupGetPubShared - :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) -groupGetPubShared (GroupPub_P256 pub) = - fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub -groupGetPubShared (GroupPub_P384 pub) = - fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub -groupGetPubShared (GroupPub_P521 pub) = - fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub -groupGetPubShared (GroupPub_X255 pub) = - fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub -groupGetPubShared (GroupPub_X448 pub) = - fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub -groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048 -groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072 -groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096 -groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144 -groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192 +-- 'ML.encapsulate' takes the parameter set as a proxy and reports a +-- failure, as every KEM in Crypto.KEM does; ML-KEM has none to report. +mlkemEncap + :: (MonadRandom r, ML.MLKEM p) + => proxy p + -> ML.EncapsulationKey p + -> r (Maybe (ML.Ciphertext p, GroupKey)) +mlkemEncap p ek = fmap f <$> fmap maybeCryptoError (ML.encapsulate p ek) + where + f (ct, sec) = (ct, convert sec) +groupEncapsulate + :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey)) +groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub +groupEncapsulate (GroupPubA_P384 pub) = getECDHPubShared GroupPubB_P384 p384 pub +groupEncapsulate (GroupPubA_P521 pub) = getECDHPubShared GroupPubB_P521 p521 pub +groupEncapsulate (GroupPubA_X255 pub) = getECDHPubShared GroupPubB_X255 x25519 pub +groupEncapsulate (GroupPubA_X448 pub) = getECDHPubShared GroupPubB_X448 x448 pub +groupEncapsulate (GroupPubA_FFDHE2048 pub) = getDHPubShared ffdhe2048 exp2048 pub GroupPubB_FFDHE2048 +groupEncapsulate (GroupPubA_FFDHE3072 pub) = getDHPubShared ffdhe3072 exp3072 pub GroupPubB_FFDHE3072 +groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096 +groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144 +groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192 +groupEncapsulate (GroupPubA_MLKEM512 pub) = + fmap (\(ct, k) -> (GroupPubB_MLKEM512 ct, k)) <$> mlkemEncap mlkem512 pub +groupEncapsulate (GroupPubA_MLKEM768 pub) = + fmap (\(ct, k) -> (GroupPubB_MLKEM768 ct, k)) <$> mlkemEncap mlkem768 pub +groupEncapsulate (GroupPubA_MLKEM1024 pub) = + fmap (\(ct, k) -> (GroupPubB_MLKEM1024 ct, k)) <$> mlkemEncap mlkem1024 pub +-- The classical part of a hybrid can fail as the group alone does: an +-- all-zero X25519 public key decodes, but the shared secret derived from +-- it is rejected. Nothing is turned into illegal_parameter by the caller. +groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = + hybrid x25519 mlkem768 e1 e2 $ \c1 k1 c2 k2 -> + -- Sec 4.1: Specifically, the order of shares in the concatenation + -- has been reversed. + (GroupPubB_X25519MLKEM768 (c1, c2), k2 <> k1) +groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = + hybrid p256 mlkem768 e1 e2 $ \c1 k1 c2 k2 -> + (GroupPubB_P256MLKEM768 (c1, c2), k1 <> k2) +groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = + hybrid p384 mlkem1024 e1 e2 $ \c1 k1 c2 k2 -> + (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> k2) + +-- Either half can refuse: the classical one rejects a peer value that would +-- make its secret degenerate, which the caller turns into +-- illegal_parameter. ML-KEM has nothing to refuse, but says so the same +-- way, so both are read alike here. +hybrid + :: (MonadRandom r, EllipticCurveDH curve, ML.MLKEM p) + => Proxy curve + -> Proxy p + -> Point curve + -> ML.EncapsulationKey p + -> (Point curve -> GroupKey -> ML.Ciphertext p -> GroupKey -> (GroupPublicB, GroupKey)) + -> r (Maybe (GroupPublicB, GroupKey)) +hybrid pc pk e1 e2 k = do + mx <- getECDHPubShared' pc e1 + case mx of + Nothing -> return Nothing + Just (c1, k1) -> fmap (\(c2, k2) -> k c1 k1 c2 k2) <$> mlkemEncap pk e2 + dhGroupGetPubShared - :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey)) -dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub -dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub -dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub -dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub -dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub + :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey)) +dhGroupGetPubShared FFDHE2048 pub = getDHPubShared' ffdhe2048 exp2048 pub +dhGroupGetPubShared FFDHE3072 pub = getDHPubShared' ffdhe3072 exp3072 pub +dhGroupGetPubShared FFDHE4096 pub = getDHPubShared' ffdhe4096 exp4096 pub +dhGroupGetPubShared FFDHE6144 pub = getDHPubShared' ffdhe6144 exp6144 pub +dhGroupGetPubShared FFDHE8192 pub = getDHPubShared' ffdhe8192 exp8192 pub dhGroupGetPubShared _ _ = return Nothing -getPubShared +getECDHPubShared + :: (MonadRandom m, EllipticCurveDH curve) + => (Point curve -> GroupPublicB) + -> proxy curve + -> Point curve + -> m (Maybe (GroupPublicB, GroupKey)) +getECDHPubShared tag proxy pub = do + mx <- maybeCryptoError <$> deriveEncrypt proxy pub + case mx of + Nothing -> return Nothing + Just (p, ECC.SharedSecret s) -> return $ Just (tag p, s) + +getECDHPubShared' + :: (MonadRandom m, EllipticCurveDH curve) + => proxy curve + -> Point curve + -> m (Maybe (Point curve, GroupKey)) +getECDHPubShared' proxy pub = do + mx <- maybeCryptoError <$> deriveEncrypt proxy pub + case mx of + Nothing -> return Nothing + Just (p, ECC.SharedSecret s) -> return $ Just (p, s) + +getDHPubShared :: MonadRandom r - => Params + => DH.Params -> Int -> PublicNumber - -> (PublicNumber -> GroupPublic) - -> r (Maybe (GroupPublic, GroupKey)) -getPubShared params expBits pub pubTag + -> (PublicNumber -> GroupPublicB) + -> r (Maybe (GroupPublicB, GroupKey)) +getDHPubShared params expBits pub pubTag | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits - let mypub = calculatePublic params mypri - let SharedKey share = getShared params mypri pub - return $ Just (pubTag mypub, SharedSecret share) + let mypub = DH.calculatePublic params mypri + DH.SharedKey share = DH.getShared params mypri pub + return $ Just (pubTag mypub, share) -getPubShared' +getDHPubShared' :: MonadRandom r - => Params + => DH.Params -> Int -> PublicNumber - -> r (Maybe (PublicNumber, SharedKey)) -getPubShared' params expBits pub + -> r (Maybe (PublicNumber, GroupKey)) +getDHPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits - let share = stripLeadingZeros (getShared params mypri pub) - return $ Just (calculatePublic params mypri, SharedKey share) + let share = stripLeadingZeros (DH.getShared params mypri pub) + return $ Just (DH.calculatePublic params mypri, convert share) -groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey -groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri -groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri -groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri -groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri -groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri -groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri -groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri -groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri -groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri -groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri -groupGetShared _ _ = Nothing +unwrap :: SharedSecret -> GroupKey +unwrap (ECC.SharedSecret sec) = sec -calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret -calcShared params pub pri - | valid params pub = Just $ SharedSecret share +groupDecapsulate :: GroupPublicB -> GroupPrivate -> Maybe GroupKey +groupDecapsulate (GroupPubB_P256 pub) (GroupPri_P256 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 pub pri +groupDecapsulate (GroupPubB_P384 pub) (GroupPri_P384 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 pub pri +groupDecapsulate (GroupPubB_P521 pub) (GroupPri_P521 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p521 pub pri +groupDecapsulate (GroupPubB_X255 pub) (GroupPri_X255 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 pub pri +groupDecapsulate (GroupPubB_X448 pub) (GroupPri_X448 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x448 pub pri +groupDecapsulate (GroupPubB_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcDHShared ffdhe2048 pub pri +groupDecapsulate (GroupPubB_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcDHShared ffdhe3072 pub pri +groupDecapsulate (GroupPubB_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcDHShared ffdhe4096 pub pri +groupDecapsulate (GroupPubB_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcDHShared ffdhe6144 pub pri +groupDecapsulate (GroupPubB_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcDHShared ffdhe8192 pub pri +groupDecapsulate (GroupPubB_MLKEM512 p) (GroupPri_MLKEM512 s) = + convert <$> maybeCryptoError (ML.decapsulate mlkem512 s p) +groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) = + convert <$> maybeCryptoError (ML.decapsulate mlkem768 s p) +groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) = + convert <$> maybeCryptoError (ML.decapsulate mlkem1024 s p) +groupDecapsulate (GroupPubB_X25519MLKEM768 (p1, p2)) (GroupPri_X25519MLKEM768 (s1, s2)) = do + bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 p1 s1 + bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem768 s2 p2) + return (bs2 <> bs1) +groupDecapsulate (GroupPubB_P256MLKEM768 (p1, p2)) (GroupPri_P256MLKEM768 (s1, s2)) = do + bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 p1 s1 + bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem768 s2 p2) + return (bs1 <> bs2) +groupDecapsulate (GroupPubB_P384MLKEM1024 (p1, p2)) (GroupPri_P384MLKEM1024 (s1, s2)) = do + bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 p1 s1 + bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem1024 s2 p2) + return (bs1 <> bs2) +groupDecapsulate _ _ = Nothing + +calcDHShared :: DH.Params -> PublicNumber -> PrivateNumber -> Maybe GroupKey +calcDHShared params pub pri + | valid params pub = Just $ convert share | otherwise = Nothing where - SharedKey share = getShared params pri pub + share = DH.getShared params pri pub -encodeGroupPublic :: GroupPublic -> ByteString -encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p -encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p -encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p -encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p -encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p -encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p -encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p -encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p -encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p -encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p +groupEncodePublicA :: GroupPublicA -> ByteString +groupEncodePublicA (GroupPubA_P256 p) = encodePoint p256 p +groupEncodePublicA (GroupPubA_P384 p) = encodePoint p384 p +groupEncodePublicA (GroupPubA_P521 p) = encodePoint p521 p +groupEncodePublicA (GroupPubA_X255 p) = encodePoint x25519 p +groupEncodePublicA (GroupPubA_X448 p) = encodePoint x448 p +groupEncodePublicA (GroupPubA_FFDHE2048 p) = enc ffdhe2048 p +groupEncodePublicA (GroupPubA_FFDHE3072 p) = enc ffdhe3072 p +groupEncodePublicA (GroupPubA_FFDHE4096 p) = enc ffdhe4096 p +groupEncodePublicA (GroupPubA_FFDHE6144 p) = enc ffdhe6144 p +groupEncodePublicA (GroupPubA_FFDHE8192 p) = enc ffdhe8192 p +groupEncodePublicA (GroupPubA_MLKEM512 p) = BA.convert p +groupEncodePublicA (GroupPubA_MLKEM768 p) = BA.convert p +groupEncodePublicA (GroupPubA_MLKEM1024 p) = BA.convert p +groupEncodePublicA (GroupPubA_X25519MLKEM768 (p1, p2)) = + BA.convert p2 <> encodePoint x25519 p1 +groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) = + encodePoint p256 p1 <> BA.convert p2 +groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) = + encodePoint p384 p1 <> BA.convert p2 -enc :: Params -> PublicNumber -> ByteString -enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p +groupEncodePublicB :: GroupPublicB -> ByteString +groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p +groupEncodePublicB (GroupPubB_P384 p) = encodePoint p384 p +groupEncodePublicB (GroupPubB_P521 p) = encodePoint p521 p +groupEncodePublicB (GroupPubB_X255 p) = encodePoint x25519 p +groupEncodePublicB (GroupPubB_X448 p) = encodePoint x448 p +groupEncodePublicB (GroupPubB_FFDHE2048 p) = enc ffdhe2048 p +groupEncodePublicB (GroupPubB_FFDHE3072 p) = enc ffdhe3072 p +groupEncodePublicB (GroupPubB_FFDHE4096 p) = enc ffdhe4096 p +groupEncodePublicB (GroupPubB_FFDHE6144 p) = enc ffdhe6144 p +groupEncodePublicB (GroupPubB_FFDHE8192 p) = enc ffdhe8192 p +groupEncodePublicB (GroupPubB_MLKEM512 p) = convert p +groupEncodePublicB (GroupPubB_MLKEM768 p) = convert p +groupEncodePublicB (GroupPubB_MLKEM1024 p) = convert p +groupEncodePublicB (GroupPubB_X25519MLKEM768 (p1, p2)) = + convert p2 <> encodePoint x25519 p1 +groupEncodePublicB (GroupPubB_P256MLKEM768 (p1, p2)) = + encodePoint p256 p1 <> convert p2 +groupEncodePublicB (GroupPubB_P384MLKEM1024 (p1, p2)) = + encodePoint p384 p1 <> convert p2 -decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic -decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs -decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs -decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs -decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs -decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs -decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs -decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs -decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs -decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs -decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs -decodeGroupPublic _ _ = error "decodeGroupPublic" +enc :: DH.Params -> PublicNumber -> ByteString +enc params (PublicNumber p) = i2ospOf_ ((DH.params_bits params + 7) `div` 8) p +groupDecodePublicA :: Group -> ByteString -> Either CryptoError GroupPublicA +groupDecodePublicA P256 bs = eitherCryptoError $ GroupPubA_P256 <$> decodePoint p256 bs +groupDecodePublicA P384 bs = eitherCryptoError $ GroupPubA_P384 <$> decodePoint p384 bs +groupDecodePublicA P521 bs = eitherCryptoError $ GroupPubA_P521 <$> decodePoint p521 bs +groupDecodePublicA X25519 bs = eitherCryptoError $ GroupPubA_X255 <$> decodePoint x25519 bs +groupDecodePublicA X448 bs = eitherCryptoError $ GroupPubA_X448 <$> decodePoint x448 bs +groupDecodePublicA FFDHE2048 bs = Right . GroupPubA_FFDHE2048 . PublicNumber $ os2ip bs +groupDecodePublicA FFDHE3072 bs = Right . GroupPubA_FFDHE3072 . PublicNumber $ os2ip bs +groupDecodePublicA FFDHE4096 bs = Right . GroupPubA_FFDHE4096 . PublicNumber $ os2ip bs +groupDecodePublicA FFDHE6144 bs = Right . GroupPubA_FFDHE6144 . PublicNumber $ os2ip bs +groupDecodePublicA FFDHE8192 bs = Right . GroupPubA_FFDHE8192 . PublicNumber $ os2ip bs +groupDecodePublicA MLKEM512 bs = case decodeEK mlkem512 bs of + Nothing -> Left CryptoError_PointFormatInvalid + Just p -> Right $ GroupPubA_MLKEM512 p +groupDecodePublicA MLKEM768 bs = case decodeEK mlkem768 bs of + Nothing -> Left CryptoError_PointFormatInvalid + Just p -> Right $ GroupPubA_MLKEM768 p +groupDecodePublicA MLKEM1024 bs = case decodeEK mlkem1024 bs of + Nothing -> Left CryptoError_PointFormatInvalid + Just p -> Right $ GroupPubA_MLKEM1024 p +groupDecodePublicA X25519MLKEM768 bs = + let (bs1, bs2) = BA.splitAt 1184 bs + in case decodeEK mlkem768 bs1 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p2 -> Right $ GroupPubA_X25519MLKEM768 (p2, p1) +groupDecodePublicA P256MLKEM768 bs = + let (bs1, bs2) = BA.splitAt 65 bs + in case decodeEK mlkem768 bs2 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p2 -> Right $ GroupPubA_P256MLKEM768 (p2, p1) +groupDecodePublicA P384MLKEM1024 bs = + let (bs1, bs2) = BA.splitAt 97 bs + in case decodeEK mlkem1024 bs2 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p2 -> Right $ GroupPubA_P384MLKEM1024 (p2, p1) +groupDecodePublicA _ _ = error "groupDecodePublicA" + +groupDecodePublicB :: Group -> ByteString -> Either CryptoError GroupPublicB +groupDecodePublicB P256 bs = eitherCryptoError $ GroupPubB_P256 <$> decodePoint p256 bs +groupDecodePublicB P384 bs = eitherCryptoError $ GroupPubB_P384 <$> decodePoint p384 bs +groupDecodePublicB P521 bs = eitherCryptoError $ GroupPubB_P521 <$> decodePoint p521 bs +groupDecodePublicB X25519 bs = eitherCryptoError $ GroupPubB_X255 <$> decodePoint x25519 bs +groupDecodePublicB X448 bs = eitherCryptoError $ GroupPubB_X448 <$> decodePoint x448 bs +groupDecodePublicB FFDHE2048 bs = Right . GroupPubB_FFDHE2048 . PublicNumber $ os2ip bs +groupDecodePublicB FFDHE3072 bs = Right . GroupPubB_FFDHE3072 . PublicNumber $ os2ip bs +groupDecodePublicB FFDHE4096 bs = Right . GroupPubB_FFDHE4096 . PublicNumber $ os2ip bs +groupDecodePublicB FFDHE6144 bs = Right . GroupPubB_FFDHE6144 . PublicNumber $ os2ip bs +groupDecodePublicB FFDHE8192 bs = Right . GroupPubB_FFDHE8192 . PublicNumber $ os2ip bs +groupDecodePublicB MLKEM512 bs = case decodeCT mlkem512 bs of + Nothing -> Left CryptoError_PointFormatInvalid + Just p -> Right $ GroupPubB_MLKEM512 p +groupDecodePublicB MLKEM768 bs = case decodeCT mlkem768 bs of + Nothing -> Left CryptoError_PointFormatInvalid + Just p -> Right $ GroupPubB_MLKEM768 p +groupDecodePublicB MLKEM1024 bs = case decodeCT mlkem1024 bs of + Nothing -> Left CryptoError_PointFormatInvalid + Just p -> Right $ GroupPubB_MLKEM1024 p +groupDecodePublicB X25519MLKEM768 bs = + let (bs1, bs2) = BA.splitAt 1088 bs + in case decodeCT mlkem768 bs1 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p2 -> Right $ GroupPubB_X25519MLKEM768 (p2, p1) +groupDecodePublicB P256MLKEM768 bs = + let (bs1, bs2) = BA.splitAt 65 bs + in case decodeCT mlkem768 bs2 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p2 -> Right $ GroupPubB_P256MLKEM768 (p2, p1) +groupDecodePublicB P384MLKEM1024 bs = + let (bs1, bs2) = BA.splitAt 97 bs + in case decodeCT mlkem1024 bs2 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of + Nothing -> Left CryptoError_PointFormatInvalid + Just p2 -> Right $ GroupPubB_P384MLKEM1024 (p2, p1) +groupDecodePublicB _ _ = error "groupDecodePublicB" + -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1. -valid :: Params -> PublicNumber -> Bool -valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 +valid :: DH.Params -> PublicNumber -> Bool +valid (DH.Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 -- strips leading zeros from the result of getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3. -stripLeadingZeros :: SharedKey -> B.ScrubbedBytes -stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb +stripLeadingZeros :: DH.SharedKey -> ScrubbedBytes +stripLeadingZeros (DH.SharedKey sb) = snd $ BA.span (== 0) sb -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -19,11 +19,19 @@ FFDHE3072, FFDHE4096, FFDHE6144, - FFDHE8192 + FFDHE8192, + MLKEM512, + MLKEM768, + MLKEM1024, + X25519MLKEM768, + P256MLKEM768, + P384MLKEM1024 ), availableFFGroups, availableECGroups, + availableHybridGroups, supportedNamedGroups, + supportedNamedGroupsTLS13, KeyExchangeSignatureAlg (..), ) where @@ -55,6 +63,18 @@ pattern FFDHE6144 = Group 259 pattern FFDHE8192 :: Group pattern FFDHE8192 = Group 260 +pattern MLKEM512 :: Group +pattern MLKEM512 = Group 512 +pattern MLKEM768 :: Group +pattern MLKEM768 = Group 513 +pattern MLKEM1024 :: Group +pattern MLKEM1024 = Group 514 +pattern X25519MLKEM768 :: Group +pattern X25519MLKEM768 = Group 4588 +pattern P256MLKEM768 :: Group +pattern P256MLKEM768 = Group 4587 +pattern P384MLKEM1024 :: Group +pattern P384MLKEM1024 = Group 4589 instance Show Group where show P256 = "P256" @@ -67,6 +87,12 @@ show FFDHE4096 = "FFDHE4096" show FFDHE6144 = "FFDHE6144" show FFDHE8192 = "FFDHE8192" + show MLKEM512 = "MLKEM512" + show MLKEM768 = "MLKEM768" + show MLKEM1024 = "MLKEM1024" + show X25519MLKEM768 = "X25519MLKEM768" + show P256MLKEM768 = "P256MLKEM768" + show P384MLKEM1024 = "P384MLKEM1024" show (Group x) = "Group " ++ show x {- FOURMOLU_ENABLE -} @@ -76,18 +102,39 @@ availableECGroups :: [Group] availableECGroups = [P256, P384, P521, X25519, X448] +availableHybridGroups :: [Group] +availableHybridGroups = [X25519MLKEM768, P256MLKEM768, P384MLKEM1024] + +-- | A list for named groups. The ordering is for client preference +-- because server preference is not used in our server +-- implementation. supportedNamedGroups :: [Group] supportedNamedGroups = - [ X25519 - , X448 - , P256 - , FFDHE2048 - , FFDHE3072 - , FFDHE4096 - , P384 - , FFDHE6144 - , FFDHE8192 - , P521 + [ X25519 -- 128 bits security + , P256 -- 128 bits security + , P384 -- 192 bits security + , X448 -- 224 bits security + , P521 -- 256 bits security + -- , FFDHE2048 -- 103 bits security + , FFDHE3072 -- 125 bits security + , FFDHE4096 -- 150 bits security + , FFDHE6144 -- 175 bits security + , FFDHE8192 -- 192 bits security + , X25519MLKEM768 + , P256MLKEM768 + , P384MLKEM1024 + , -- , MLKEM512 + MLKEM768 + , MLKEM1024 + ] + +supportedNamedGroupsTLS13 :: [[Group]] +supportedNamedGroupsTLS13 = + [ [X25519MLKEM768, P256MLKEM768, P384MLKEM1024] + , [X25519, P256] + , [P384, X448, P521] + , [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192] + , [MLKEM768, MLKEM1024] ] -- Key-exchange signature algorithm, in close relation to ciphers diff --git a/Network/TLS/Error.hs b/Network/TLS/Error.hs --- a/Network/TLS/Error.hs +++ b/Network/TLS/Error.hs @@ -3,8 +3,7 @@ module Network.TLS.Error where -import Control.Exception (Exception (..)) -import Data.Typeable +import qualified Control.Exception as E import Network.TLS.Imports @@ -34,7 +33,7 @@ | Error_Packet_unexpected String String | Error_Packet_Parsing String | Error_TCP_Terminate - deriving (Eq, Show, Typeable) + deriving (Eq, Show) ---------------------------------------------------------------- @@ -61,9 +60,9 @@ -- handshake had occurred. -- Indicates that this library has been used incorrectly. MissingHandshake - deriving (Show, Eq, Typeable) + deriving (Show, Eq) -instance Exception TLSException +instance E.Exception TLSException ---------------------------------------------------------------- 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 @@ -428,7 +428,22 @@ -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID + + -- | Decode an extension's body as it appears in the given message. + -- + -- 'Nothing' covers both ways this can fail to produce a value: a body + -- that does not parse, and a message the extension is not defined in. + -- Both reach the peer the same way, as the decode_error alert that + -- 'lookupAndDecode' and 'lookupAndDecodeAndDo' raise, which is what + -- either case warrants. + -- + -- So the last clause of an instance is @Nothing@, never @error@: the + -- message type is chosen by this library rather than by the peer, so an + -- unhandled one would be our own bug -- and turning our bug into an + -- ErrorCall thrown from pure code, out through the handshake and into + -- the application, is a worse answer than dropping the one connection. extensionDecode :: MessageType -> ByteString -> Maybe a + extensionEncode :: a -> ByteString data MessageType @@ -438,12 +453,12 @@ | MsgTEncryptedExtensions | MsgTNewSessionTicket | MsgTCertificateRequest - deriving (Eq, Show) + deriving (Eq, Show, Enum, Bounded) ------------------------------------------------------------ -- | Server Name extension including the name type and the associated name. --- the associated name decoding is dependant of its name type. +-- the associated name decoding is dependent of its name type. -- name type = 0 : hostname newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq) @@ -466,21 +481,32 @@ where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt, opaque)) = putWord8 nt >> putBytes opaque - extensionDecode MsgTClientHello = decodeServerName + extensionDecode MsgTClientHello = decodeServerNameList extensionDecode MsgTServerHello = decodeServerName extensionDecode MsgTEncryptedExtensions = decodeServerName - extensionDecode _ = error "extensionDecode: ServerName" + extensionDecode _ = const Nothing decodeServerName :: ByteString -> Maybe ServerName decodeServerName "" = Just $ ServerName [] -- dirty hack for servers -decodeServerName bs = runGetMaybe decode bs +decodeServerName bs = decodeServerNameList bs + +-- RFC 6066 Section 3: server_name_list<1..2^16-1> of +-- HostName<1..2^16-1>, which leaves no room for an empty extension, an +-- empty list, an empty host name nor trailing data. +decodeServerNameList :: ByteString -> Maybe ServerName +decodeServerNameList = runGetMaybe decode where decode = do len <- fromIntegral <$> getWord16 - ServerName <$> getList len getServerName + names <- getList len getServerName + when (null names) $ fail "empty server_name_list" + r <- remaining + when (r /= 0) $ fail "trailing data in server_name" + return $ ServerName names getServerName = do ty <- getWord8 snameParsed <- getOpaque16 + when (ty == 0 && B.null snameParsed) $ fail "empty host_name" let sname = B.copy snameParsed name = case ty of 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion @@ -521,7 +547,7 @@ extensionDecode MsgTClientHello = decodeMaxFragmentLength extensionDecode MsgTServerHello = decodeMaxFragmentLength extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength - extensionDecode _ = error "extensionDecode: MaxFragmentLength" + extensionDecode _ = const Nothing decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8 @@ -542,7 +568,7 @@ extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups extensionDecode MsgTClientHello = decodeSupportedGroups extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups - extensionDecode _ = error "extensionDecode: SupportedGroups" + extensionDecode _ = const Nothing decodeSupportedGroups :: ByteString -> Maybe SupportedGroups decodeSupportedGroups = @@ -577,15 +603,18 @@ extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats extensionDecode MsgTClientHello = decodeEcPointFormatsSupported extensionDecode MsgTServerHello = decodeEcPointFormatsSupported - extensionDecode _ = error "extensionDecode: EcPointFormatsSupported" + extensionDecode _ = const Nothing decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported -decodeEcPointFormatsSupported = - runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8) +decodeEcPointFormatsSupported = runGetMaybe $ do + formats <- getWords8 + -- RFC 8422 Section 5.1.2: ec_point_format_list<1..2^8-1> + when (null formats) $ fail "empty ec_point_format_list" + return $ EcPointFormatsSupported $ map EcPointFormat formats ------------------------------------------------------------ -newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] +newtype SignatureAlgorithms = SignatureAlgorithms [SignatureScheme] deriving (Show, Eq) instance Extension SignatureAlgorithms where @@ -593,16 +622,16 @@ extensionEncode (SignatureAlgorithms algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) - >> mapM_ putSignatureHashAlgorithm algs + >> mapM_ putSignatureScheme algs extensionDecode MsgTClientHello = decodeSignatureAlgorithms extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms - extensionDecode _ = error "extensionDecode: SignatureAlgorithms" + extensionDecode _ = const Nothing decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms 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" @@ -632,7 +661,7 @@ extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode extensionDecode MsgTClientHello = decodeHeartBeat extensionDecode MsgTServerHello = decodeHeartBeat - extensionDecode _ = error "extensionDecode: HeartBeat" + extensionDecode _ = const Nothing decodeHeartBeat :: ByteString -> Maybe HeartBeat decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8 @@ -651,16 +680,23 @@ extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation - extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation" + extensionDecode _ = const Nothing decodeApplicationLayerProtocolNegotiation :: ByteString -> Maybe ApplicationLayerProtocolNegotiation decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do len <- getWord16 - ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN + protos <- getList (fromIntegral len) getALPN + -- RFC 7301 Section 3.1: protocol_name_list<2..2^16-1> of + -- ProtocolName<1..2^8-1>, with nothing after it. + when (null protos) $ fail "empty protocol_name_list" + r <- remaining + when (r /= 0) $ fail "trailing data in application_layer_protocol_negotiation" + return $ ApplicationLayerProtocolNegotiation protos where getALPN = do alpnParsed <- getOpaque8 + when (B.null alpnParsed) $ fail "empty ProtocolName" let alpn = B.copy alpnParsed return (B.length alpn + 1, alpn) @@ -674,7 +710,7 @@ extensionEncode ExtendedMainSecret = B.empty extensionDecode MsgTClientHello "" = Just ExtendedMainSecret extensionDecode MsgTServerHello "" = Just ExtendedMainSecret - extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret" + extensionDecode _ _ = Nothing ------------------------------------------------------------ @@ -749,7 +785,7 @@ extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket extensionDecode MsgTClientHello = decodeSessionTicket extensionDecode MsgTServerHello = decodeSessionTicket - extensionDecode _ = error "extensionDecode: SessionTicket" + extensionDecode _ = const Nothing decodeSessionTicket :: ByteString -> Maybe SessionTicket decodeSessionTicket = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes) @@ -792,7 +828,7 @@ fromIntegral w16 extensionDecode MsgTClientHello = decodePreSharedKeyClientHello extensionDecode MsgTServerHello = decodePreSharedKeyServerHello - extensionDecode _ = error "extensionDecode: PreShareKey" + extensionDecode _ = const Nothing decodePreSharedKeyClientHello :: ByteString -> Maybe PreSharedKey decodePreSharedKeyClientHello = runGetMaybe $ do @@ -832,12 +868,11 @@ extensionID _ = EID_EarlyData extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32 - extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing) - extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing) - extensionDecode MsgTNewSessionTicket = - runGetMaybe $ - EarlyDataIndication . Just <$> getWord32 - extensionDecode _ = error "extensionDecode: EarlyDataIndication" + extensionDecode MsgTClientHello "" = Just (EarlyDataIndication Nothing) + extensionDecode MsgTEncryptedExtensions "" = Just (EarlyDataIndication Nothing) + extensionDecode MsgTNewSessionTicket bs = + runGetMaybe (EarlyDataIndication . Just <$> getWord32) bs + extensionDecode _ _ = Nothing ------------------------------------------------------------ @@ -860,7 +895,7 @@ putBinaryVersion ver extensionDecode MsgTClientHello = decodeSupportedVersionsClientHello extensionDecode MsgTServerHello = decodeSupportedVersionsServerHello - extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello" + extensionDecode _ = const Nothing decodeSupportedVersionsClientHello :: ByteString -> Maybe SupportedVersions decodeSupportedVersionsClientHello = runGetMaybe $ do @@ -888,7 +923,7 @@ extensionID _ = EID_Cookie extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16) - extensionDecode _ = error "extensionDecode: Cookie" + extensionDecode _ = const Nothing ------------------------------------------------------------ @@ -916,7 +951,7 @@ putWords8 $ map fromPskKexMode pkms extensionDecode MsgTClientHello = decodePskKeyExchangeModes - extensionDecode _ = error "extensionDecode: PskKeyExchangeModes" + extensionDecode _ = const Nothing decodePskKeyExchangeModes :: ByteString -> Maybe PskKeyExchangeModes decodePskKeyExchangeModes = @@ -935,7 +970,7 @@ putDNames names extensionDecode MsgTClientHello = decodeCertificateAuthorities extensionDecode MsgTCertificateRequest = decodeCertificateAuthorities - extensionDecode _ = error "extensionDecode: CertificateAuthorities" + extensionDecode _ = const Nothing decodeCertificateAuthorities :: ByteString -> Maybe CertificateAuthorities decodeCertificateAuthorities = @@ -949,11 +984,11 @@ extensionID _ = EID_PostHandshakeAuth extensionEncode _ = B.empty extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth - extensionDecode _ = error "extensionDecode: PostHandshakeAuth" + extensionDecode _ = const Nothing ------------------------------------------------------------ -newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] +newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [SignatureScheme] deriving (Show, Eq) instance Extension SignatureAlgorithmsCert where @@ -961,16 +996,16 @@ extensionEncode (SignatureAlgorithmsCert algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) - >> mapM_ putSignatureHashAlgorithm algs + >> mapM_ putSignatureScheme algs extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert - extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert" + extensionDecode _ = const Nothing decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert decodeSignatureAlgorithmsCert = runGetMaybe $ do len <- getWord16 SignatureAlgorithmsCert - <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + <$> getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh)) ------------------------------------------------------------ @@ -1021,7 +1056,7 @@ extensionDecode MsgTClientHello = decodeKeyShareClientHello extensionDecode MsgTServerHello = decodeKeyShareServerHello extensionDecode MsgTHelloRetryRequest = decodeKeyShareHRR - extensionDecode _ = error "extensionDecode: KeyShare" + extensionDecode _ = const Nothing decodeKeyShareClientHello :: ByteString -> Maybe KeyShare decodeKeyShareClientHello = runGetMaybe $ do @@ -1059,7 +1094,7 @@ putWord8 $ fromIntegral (length ids * 2) mapM_ (putWord16 . fromExtensionID) ids extensionDecode MsgTClientHello = decodeEchOuterExtensions - extensionDecode _ = error "extensionDecode: EchOuterExtensions" + extensionDecode _ = const Nothing decodeEchOuterExtensions :: ByteString -> Maybe EchOuterExtensions decodeEchOuterExtensions = runGetMaybe $ do @@ -1120,7 +1155,7 @@ extensionDecode MsgTClientHello = decodeECHClientHello extensionDecode MsgTEncryptedExtensions = decodeECHEncryptedExtensions extensionDecode MsgTHelloRetryRequest = decodeECHHelloRetryRequest - extensionDecode _ = error "extensionDecode: EncryptedClientHello" + extensionDecode _ = const Nothing decodeECH :: ByteString -> Maybe EncryptedClientHello decodeECH bs = @@ -1172,4 +1207,4 @@ opaque <- getOpaque8 let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque return $ SecureRenegotiation cvd svd - extensionDecode _ = error "extensionDecode: SecureRenegotiation" + extensionDecode _ = const Nothing diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Network.TLS.Extra.Cipher ( -- * Cipher suite ciphersuite_default, @@ -70,11 +71,12 @@ ) where import Crypto.Cipher.AES -import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 +import qualified Crypto.Cipher.AES.GCM as GCM +import qualified Crypto.Cipher.ChaCha.Poly1305 as ChaChaOne import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error -import qualified Crypto.MAC.Poly1305 as Poly1305 import Crypto.System.CPU +import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.Tuple (swap) @@ -572,9 +574,22 @@ sortOptimized :: [CipherSet] -> [Cipher] sortOptimized = concatMap f where + -- crypton 2.2 gives the AArch64 instructions their own names. Before + -- it, the ARMv8 path set the slots Haskell read as AESNI and PCLMUL, so + -- asking for those names answered "is AES fast here" on both + -- architectures; from 2.2 they are x86's names, which an AArch64 machine + -- does not have. hasAESAcceleration and hasGHASHAcceleration ask the + -- question without naming an instruction set. Either spelling compiles + -- against either version -- the names are pattern synonyms now -- so + -- nothing but this guard says which one is right for which. f (SetAead gcm chacha ccm) +#if MIN_VERSION_crypton(2,2,0) + | not hasAESAcceleration = chacha ++ gcm ++ ccm + | not hasGHASHAcceleration = ccm ++ chacha ++ gcm +#else | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm +#endif | otherwise = gcm ++ ccm ++ chacha f (SetOther ciphers) = ciphers @@ -619,20 +634,40 @@ in simpleDecrypt aeadIni ad d 8 ) +-- The AES-GCM and ChaCha20-Poly1305 ciphers go through the one-call +-- interfaces crypton added for this, not the general AEAD one. Two things +-- are saved on every record. +-- +-- The state the key alone determines -- the AES key schedule and the table of +-- multiples of H -- was rebuilt for each record by aeadInit; newContext +-- builds it once, here, where the key is fixed. +-- +-- And the general interface reaches its cipher through AEADModeImpl, whose +-- fields are @forall ba. ByteArray ba => ...@, so a dictionary is passed at +-- every call and no pragma can remove it. +-- +-- Measured in C on an idle Haswell, against what this did before: 64-byte +-- record 0.169 -> 0.047 microseconds, 1400-byte 0.501 -> 0.301, 16 KiB +-- 3.285 -> 3.207. It is a fixed cost that goes, so it is most of a small +-- record and little of a full one. +aesgcm :: BulkDirection -> BulkKey -> BulkAEAD +aesgcm BulkEncrypt key = + let ctx = noFail (GCM.newContext key) + in \nonce d ad -> + let sealed = GCM.encrypt ctx nonce ad d 16 + (out, tag) = B.splitAt (B.length sealed - 16) sealed + in (out, AuthTag (convert tag)) +aesgcm BulkDecrypt key = + let ctx = noFail (GCM.newContext key) + in \nonce d ad -> GCM.decryptWithTag ctx nonce ad d 16 + aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD -aes128gcm BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16 - ) -aes128gcm BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in simpleDecrypt aeadIni ad d 16 - ) +aes128gcm = aesgcm +aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD +aes256gcm = aesgcm + + aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD aes256ccm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 @@ -665,20 +700,6 @@ in simpleDecrypt aeadIni ad d 8 ) -aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD -aes256gcm BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16 - ) -aes256gcm BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in simpleDecrypt aeadIni ad d 16 - ) - simpleDecrypt :: AEAD cipher -> ByteString -> ByteString -> Int -> (ByteString, AuthTag) simpleDecrypt aeadIni header input taglen = (output, tag) @@ -690,23 +711,23 @@ noFail :: CryptoFailable a -> a noFail = throwCryptoError +-- The one-call interface here too, and for the same two reasons as the AES +-- ciphers above: the step-at-a-time Crypto.Cipher.ChaChaPoly1305 is eight +-- foreign calls and the allocations between them for a message that arrived +-- whole, and the general AEAD interface passes a dictionary a call. +-- +-- Measured through the Haskell interface on an Apple M4: 100 bytes 0.97 -> +-- 0.415 microseconds, 1400 bytes 2.89 -> 2.36. chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD -chacha20poly1305 BulkEncrypt key nonce = - let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in ( \input ad -> - let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) - (output, st3) = ChaChaPoly1305.encrypt input st2 - Poly1305.Auth tag = ChaChaPoly1305.finalize st3 - in (output, AuthTag tag) - ) -chacha20poly1305 BulkDecrypt key nonce = - let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in ( \input ad -> - let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) - (output, st3) = ChaChaPoly1305.decrypt input st2 - Poly1305.Auth tag = ChaChaPoly1305.finalize st3 - in (output, AuthTag tag) - ) +chacha20poly1305 BulkEncrypt key = + let ctx = noFail (ChaChaOne.newContext key) + in \nonce d ad -> + let sealed = noFail (ChaChaOne.encrypt ctx nonce ad d 16) + (out, tag) = B.splitAt (B.length sealed - 16) sealed + in (out, AuthTag (convert tag)) +chacha20poly1305 BulkDecrypt key = + let ctx = noFail (ChaChaOne.newContext key) + in \nonce d ad -> noFail (ChaChaOne.decryptWithTag ctx nonce ad d 16) ---------------------------------------------------------------- diff --git a/Network/TLS/Extra/CipherCBC.hs b/Network/TLS/Extra/CipherCBC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extra/CipherCBC.hs @@ -0,0 +1,201 @@ +module Network.TLS.Extra.CipherCBC ( + -- * TLS 1.2 CBC ciphers with PFS and SHA2 + ciphersuite_pfs_sha2_cbc, + ciphersuite_ecdhe_sha2_cbc, + ciphersuite_dhe_rsa_sha2_cbc, + + -- ** Individual CBC ciphers + cipher_DHE_RSA_AES128_SHA256, + cipher_DHE_RSA_AES256_SHA256, + cipher_ECDHE_RSA_AES128CBC_SHA256, + cipher_ECDHE_RSA_AES256CBC_SHA384, + cipher_ECDHE_ECDSA_AES128CBC_SHA256, +) where + +import Crypto.Cipher.AES +import Crypto.Cipher.Types hiding (Cipher, cipherName) +import Crypto.Error +-- import Crypto.System.CPU +import qualified Data.ByteString as B + +import Network.TLS.Cipher +import Network.TLS.Imports +import Network.TLS.Types hiding (IV) + +---------------------------------------------------------------- + +-- | TLS 1.2 AES CBC ciphers with DHE or ECDHE key exchange, ECDSA or RSA +-- authentication and a SHA256 or SHA2384 MAC. +-- For legacy applications only, deprecated in HTTPS. +ciphersuite_pfs_sha2_cbc :: [Cipher] +ciphersuite_pfs_sha2_cbc = + [ cipher_ECDHE_ECDSA_AES128CBC_SHA256 + , cipher_ECDHE_ECDSA_AES256CBC_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA256 + , cipher_ECDHE_RSA_AES256CBC_SHA384 + , cipher_DHE_RSA_AES128_SHA256 + , cipher_DHE_RSA_AES256_SHA256 + ] + +-- | TLS 1.2 AES CBC ciphers with ECDHE key exchange, ECDSA or RSA +-- authentication and a SHA256 or SHA2384 MAC. +-- For legacy applications only, deprecated in HTTPS. +ciphersuite_ecdhe_sha2_cbc :: [Cipher] +ciphersuite_ecdhe_sha2_cbc = + [ cipher_ECDHE_ECDSA_AES128CBC_SHA256 + , cipher_ECDHE_ECDSA_AES256CBC_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA256 + , cipher_ECDHE_RSA_AES256CBC_SHA384 + ] + +-- | TLS 1.2 AES CBC ciphers with DHE key exchange, RSA authentication and a +-- SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +ciphersuite_dhe_rsa_sha2_cbc :: [Cipher] +ciphersuite_dhe_rsa_sha2_cbc = + [ cipher_DHE_RSA_AES256_SHA256 + , cipher_DHE_RSA_AES128_SHA256 + ] + +---------------------------------------------------------------- + +-- | TLS 1.2 AES128 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_DHE_RSA_AES128_SHA256 :: Cipher +cipher_DHE_RSA_AES128_SHA256 = + Cipher + { cipherID = 0x0067 + , cipherName = "DHE-RSA-AES128-SHA256" + , cipherBulk = bulk_aes128 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +-- | TLS 1.2 AES256 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_DHE_RSA_AES256_SHA256 :: Cipher +cipher_DHE_RSA_AES256_SHA256 = + cipher_DHE_RSA_AES128_SHA256 + { cipherID = 0x006B + , cipherName = "DHE-RSA-AES256-SHA256" + , cipherBulk = bulk_aes256 + } + +-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, RSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher +cipher_ECDHE_RSA_AES128CBC_SHA256 = + Cipher + { cipherID = 0xC027 + , cipherName = "ECDHE-RSA-AES128CBC-SHA256" + , cipherBulk = bulk_aes128 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, RSA authentication and a SHA384 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher +cipher_ECDHE_RSA_AES256CBC_SHA384 = + Cipher + { cipherID = 0xC028 + , cipherName = "ECDHE-RSA-AES256CBC-SHA384" + , cipherBulk = bulk_aes256 + , cipherHash = SHA384 + , cipherPRFHash = Just SHA384 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, ECDSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128CBC_SHA256 = + Cipher + { cipherID = 0xc023 + , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256" + , cipherBulk = bulk_aes128 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, ECDSA authentication and a SHA384 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher +cipher_ECDHE_ECDSA_AES256CBC_SHA384 = + Cipher + { cipherID = 0xC024 + , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384" + , cipherBulk = bulk_aes256 + , cipherHash = SHA384 + , cipherPRFHash = Just SHA384 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +---------------------------------------------------------------- + +aes128cbc :: BulkDirection -> BulkKey -> BulkBlock +aes128cbc BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \iv input -> + let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output) + ) +aes128cbc BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \iv input -> + let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input) + ) + +aes256cbc :: BulkDirection -> BulkKey -> BulkBlock +aes256cbc BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \iv input -> + let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output) + ) +aes256cbc BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \iv input -> + let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input) + ) + +makeIV_ :: BlockCipher a => B.ByteString -> IV a +makeIV_ = fromMaybe (error "makeIV_") . makeIV + +takelast :: Int -> B.ByteString -> B.ByteString +takelast i b = B.drop (B.length b - i) b + +noFail :: CryptoFailable a -> a +noFail = throwCryptoError + +---------------------------------------------------------------- + +bulk_aes128 :: Bulk +bulk_aes128 = + Bulk + { bulkName = "AES128" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes128cbc + } + +bulk_aes256 :: Bulk +bulk_aes256 = + Bulk + { bulkName = "AES256" + , bulkKeySize = 32 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes256cbc + } diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -25,9 +25,9 @@ -- This is called automatically by 'recvData', in a context where the read lock -- is already taken. So contrary to 'handshake' above, here we only need to -- call withWriteLock. -handshakeWith :: MonadIO m => Context -> Handshake -> m () -handshakeWith ctx hs = +handshakeWith :: MonadIO m => Context -> HandshakeR -> m () +handshakeWith ctx hsr = liftIO $ withWriteLock ctx $ handleException ctx $ - doHandshakeWith_ (ctxRoleParams ctx) ctx hs + doHandshakeWith_ (ctxRoleParams ctx) ctx hsr diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -3,35 +3,104 @@ badCertificate, rejectOnException, verifyLeafKeyUsage, + verifyLeafKeyUsagePurpose, + verifyLeafKeySize, extractCAname, ) where -import Control.Exception (SomeException) +import qualified Control.Exception as E import Control.Monad (unless) import Control.Monad.State.Strict -import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet) +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 +import qualified Data.ByteString.Char8 as C8 +import Data.List (intercalate, isInfixOf) +import Data.X509 ( + ExtExtendedKeyUsage (..), + ExtKeyUsage (..), + ExtKeyUsageFlag, + ExtKeyUsagePurpose (..), + PubKey (PubKeyRSA), + encodeSignedObject, + extensionGet, + getDistinguishedElements, + ) import Network.TLS.Context.Internal +import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.X509 --- on certificate reject, throw an exception with the proper protocol alert error. -certificateRejected :: MonadIO m => CertificateRejectReason -> m a -certificateRejected CertificateRejectRevoked = - throwCore $ Error_Protocol "certificate is revoked" CertificateRevoked -certificateRejected CertificateRejectExpired = - throwCore $ Error_Protocol "certificate has expired" CertificateExpired -certificateRejected CertificateRejectUnknownCA = - throwCore $ Error_Protocol "certificate has unknown CA" UnknownCa -certificateRejected CertificateRejectAbsent = - throwCore $ Error_Protocol "certificate is missing" CertificateRequired -certificateRejected (CertificateRejectOther s) = - throwCore $ Error_Protocol ("certificate rejected: " ++ s) CertificateUnknown +-- | On certificate reject, throw an exception with the proper protocol alert +-- error. The message carries the reasons of the validation and the subject +-- and issuer of the leaf; the whole chain goes to 'debugError' in PEM. +certificateRejected + :: MonadIO m + => Context -> [FailedReason] -> CertificateChain -> CertificateRejectReason -> m a +certificateRejected ctx reasons cc reason = do + let ~pem = chainPEM cc + liftIO $ debugError (ctxDebug ctx) $ msg ++ details ++ "\n" ++ pem + throwCore $ Error_Protocol (msg ++ details) alert + where + (msg, alert) = case reason of + CertificateRejectRevoked -> ("certificate is revoked", CertificateRevoked) + CertificateRejectExpired -> ("certificate has expired", CertificateExpired) + CertificateRejectUnknownCA -> ("certificate has unknown CA", UnknownCa) + CertificateRejectAbsent -> ("certificate is missing", CertificateRequired) + CertificateRejectOther s -> ("certificate rejected: " ++ s, CertificateUnknown) + -- wrapCertificateChecks may have put the reasons in the message already + details = + concatMap ("; " ++) $ + [rs | not (null reasons), not (rs `isInfixOf` msg)] ++ leafSummary cc + rs = show reasons +-- | The subject and issuer of the leaf certificate. +leafSummary :: CertificateChain -> [String] +leafSummary (CertificateChain []) = [] +leafSummary (CertificateChain (signed : _)) = + [ "subject: " ++ showDN (certSubjectDN cert) + , "issuer: " ++ showDN (certIssuerDN cert) + ] + where + cert = getCertificate signed + +showDN :: DistinguishedName -> String +showDN dn = + intercalate + ", " + [name oid ++ "=" ++ value cs | (oid, cs) <- getDistinguishedElements dn] + where + name oid = maybe (intercalate "." $ map show oid) id $ lookup oid names + value = maybe "?" id . asn1CharacterToString + names = + [ ([2, 5, 4, 3], "CN") + , ([2, 5, 4, 6], "C") + , ([2, 5, 4, 7], "L") + , ([2, 5, 4, 8], "ST") + , ([2, 5, 4, 10], "O") + , ([2, 5, 4, 11], "OU") + ] + +-- | The certificates of the chain in PEM, leaf first. +chainPEM :: CertificateChain -> String +chainPEM (CertificateChain certs) = concatMap pem certs + where + pem signed = + "-----BEGIN CERTIFICATE-----\n" + ++ concatMap + ((++ "\n") . C8.unpack) + (lines64 $ convertToBase Base64 $ encodeSignedObject signed) + ++ "-----END CERTIFICATE-----\n" + lines64 bs + | B.null bs = [] + | otherwise = let (l, r) = B.splitAt 64 bs in l : lines64 r + badCertificate :: MonadIO m => String -> m a badCertificate msg = throwCore $ Error_Protocol msg BadCertificate -rejectOnException :: SomeException -> IO CertificateUsage +rejectOnException :: E.SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m () @@ -46,6 +115,40 @@ case extensionGet (certExtensions cert) of Nothing -> True -- unrestricted cert Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags + +verifyLeafKeyUsagePurpose + :: MonadIO m => [ExtKeyUsagePurpose] -> CertificateChain -> m () +verifyLeafKeyUsagePurpose _ (CertificateChain []) = return () +verifyLeafKeyUsagePurpose validPurposes (CertificateChain (signed : _)) = + unless verified $ + badCertificate $ + "certificate is not allowed for any of " ++ show validPurposes + where + cert = getCertificate signed + verified = case extensionGet (certExtensions cert) of + Nothing -> True + 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.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client ( handshakeClient, @@ -26,8 +27,9 @@ ---------------------------------------------------------------- -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () -handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx +handshakeClientWith + :: ClientParams -> Context -> HandshakeR -> IO () +handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx handshakeClientWith _ _ _ = throwCore $ Error_Protocol @@ -38,16 +40,34 @@ -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do - groups <- case clientSessions cparams of - [] -> return groupsSupported + grps <- case clientSessions cparams of + [] -> + return $ + Groups + { grpsSupported = groupsSupported + , grpsSelected = groupsSelected + } (_, sdata) : _ -> case sessionGroup sdata of - Nothing -> return [] -- TLS 1.2 or earlier + Nothing -> + -- TLS 1.2 or earlier + return $ + Groups + { grpsSupported = groupsSupported -- for ciphers + , grpsSelected = [] + } Just grp - | grp `elem` groupsSupported -> return $ grp : filter (/= grp) groupsSupported + | grp `elem` groupsSupported -> do + let supported = grp : filter (/= grp) groupsSupported + return $ + Groups + { grpsSupported = supported + , grpsSelected = [grp] + } | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect" - handshake cparams ctx groups Nothing + handshake cparams ctx grps Nothing where groupsSupported = supportedGroups (ctxSupported ctx) + groupsSelected = onSelectKeyShareGroups (clientHooks cparams) groupsSupported -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a @@ -59,10 +79,10 @@ handshake :: ClientParams -> Context - -> [Group] + -> Groups -> Maybe (ClientRandom, Session, Version) -> IO () -handshake cparams ctx groups mparams = do +handshake cparams ctx grps@Groups{..} mparams = do -------------------------------- -- Sending ClientHello pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx @@ -70,21 +90,21 @@ let async = rtt0 && not (ctxQUICMode ctx) when async $ do chSentTime <- getCurrentTimeFromBase - asyncServerHello13 cparams ctx groupToSend chSentTime + asyncServerHello13 cparams ctx grpsSelected chSentTime updateMeasure ctx incrementNbHandshakes - crand <- sendClientHello cparams ctx groups mparams pskinfo + crand <- + sendClientHello cparams ctx grps mparams pskinfo -------------------------------- -- Receiving ServerHello unless async $ do - (ver, hss, hrr) <- receiveServerHello cparams ctx mparams - -------------------------------- + (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams -- Switching to HRR, TLS 1.2 or TLS 1.3 case ver of TLS13 | hrr -> - helloRetry cparams ctx mparams ver crand $ drop 1 groups + helloRetry cparams ctx mparams ver crand grpsSupported grpsSelected | otherwise -> do - recvServerSecondFlight13 cparams ctx groupToSend + recvServerSecondFlight13 cparams ctx grpsSelected sendClientSecondFlight13 cparams ctx _ | rtt0 -> @@ -93,11 +113,9 @@ "server denied TLS 1.3 when connecting with early data" HandshakeFailure | otherwise -> do - recvServerFirstFlight12 cparams ctx hss + recvServerFirstFlight12 cparams ctx hbs sendClientSecondFlight12 cparams ctx recvServerSecondFlight12 cparams ctx - where - groupToSend = listToMaybe groups ---------------------------------------------------------------- @@ -108,30 +126,59 @@ -> Version -> ClientRandom -> [Group] + -> [Group] -> IO () -helloRetry cparams ctx mparams ver crand groups = do - when (null groups) $ +helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do + when (null groupsSupported) $ throwCore $ - Error_Protocol "group is exhausted in the client side" IllegalParameter + Error_Protocol "no supported groups on the client side" IllegalParameter when (isJust mparams) $ throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup) - | selectedGroup `elem` groups -> do - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest - clearTxRecordState ctx - let cparams' = cparams{clientUseEarlyData = False} - runPacketFlight ctx $ sendChangeCipherSpec13 ctx - clientSession <- tls13stSession <$> getTLS13State ctx - handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) + -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups + -- and MUST NOT already have been offered in the initial key_share. + | selectedGroup `elem` groupsSupported + && selectedGroup `notElem` groupsSelected -> + retry [selectedGroup] + | selectedGroup `elem` groupsSelected -> + throwCore $ + Error_Protocol + "server selected a group already offered in key_share" + IllegalParameter | otherwise -> throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter Just _ -> error "handshake: invalid KeyShare value" - Nothing -> - throwCore $ - Error_Protocol - "key exchange not implemented in HRR, expected key_share extension" - HandshakeFailure + -- RFC 9846 Section 4.1.4: without key_share, the key shares are + -- sent again, but the HelloRetryRequest must change something. + Nothing -> do + mcookie <- usingState_ ctx getTLS13Cookie + when (isNothing mcookie) $ + throwCore $ + Error_Protocol + "HelloRetryRequest would not change ClientHello" + IllegalParameter + retry groupsSelected + where + retry selected = do + usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest + clearTxRecordState ctx + let cparams' = cparams{clientUseEarlyData = False} + runPacketFlight ctx $ sendChangeCipherSpec13 ctx + clientSession <- tls13stSession <$> getTLS13State ctx + -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical + -- to the first except for the specific listed changes. + -- supported_groups is NOT on that list, so it must be unchanged. + let grps = + Groups + { grpsSupported = groupsSupported + , grpsSelected = selected + } + handshake + cparams' + ctx + grps + (Just (crand, clientSession, ver)) diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -5,10 +5,13 @@ module Network.TLS.Handshake.Client.ClientHello ( sendClientHello, getPreSharedKeyInfo, + Groups (..), ) where import qualified Control.Exception as E -import Crypto.HPKE +import Crypto.HPKE hiding (CipherText, PlainText) +import Data.ByteArray (convert) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.ECH.Config import System.Random @@ -41,16 +44,26 @@ ---------------------------------------------------------------- +data Groups = Groups + { grpsSupported :: [Group] + -- ^ For supported_group, head is identical to key_share + , grpsSelected :: [Group] + -- ^ For key_share + } + deriving (Eq, Show) + +---------------------------------------------------------------- + sendClientHello :: ClientParams -> Context - -> [Group] + -> Groups -> Maybe (ClientRandom, Session, Version) -> PreSharedKeyInfo -> IO ClientRandom -sendClientHello cparams ctx groups mparams pskinfo = do +sendClientHello cparams ctx grps mparams pskinfo = do crand <- generateClientHelloParams mparams -- Inner for ECH - sendClientHello' cparams ctx groups crand pskinfo + sendClientHello' cparams ctx grps crand pskinfo return crand where highestVer = maximum $ supportedVersions $ ctxSupported ctx @@ -89,14 +102,11 @@ sendClientHello' :: ClientParams -> Context - -> [Group] + -> Groups -> ClientRandom - -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32) - , Maybe CipherChoice - , Bool - ) + -> PreSharedKeyInfo -> IO () -sendClientHello' cparams ctx groups crand (pskInfo, rtt0info, rtt0) = do +sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer clientSession <- tls13stSession <$> getTLS13State ctx hrr <- usingState_ ctx getTLS13HRR @@ -127,17 +137,22 @@ Nothing -> do if hrr then do - chI <- fromJust <$> usingHState ctx getClientHello + (chI, _) <- fromJust <$> usingHState ctx getClientHello let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)} - usingHState ctx $ setClientHello ch0' + -- [] will be overridden via + -- encodeUpdateTranscriptHash12 + usingHState ctx $ setClientHello ch0' [] return ch0' else do gEchExt <- greasingEchExt let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)} - usingHState ctx $ setClientHello ch0' + -- [] will be overridden via + -- encodeUpdateTranscriptHash12 + usingHState ctx $ setClientHello ch0' [] return ch0' Just echParams -> do - usingHState ctx $ setClientHello ch0 + let encoded = encodeHandshake $ ClientHello ch0 + usingHState ctx $ setClientHello ch0 [encoded] mcrandO <- usingHState ctx getOuterClientRandom crandO <- case mcrandO of Nothing -> clientRandom ctx @@ -148,9 +163,11 @@ mpskExt <- randomPreSharedKeyExt createEncryptedClientHello ctx ch0 echParams crandO mpskExt else do - usingHState ctx $ setClientHello ch0 + -- [] will be overridden via + -- encodeUpdateTranscriptHash12 + usingHState ctx $ setClientHello ch0 [] return ch0 - sendPacket12 ctx $ Handshake [ClientHello ch] + sendPacket12 ctx $ Handshake [ClientHello ch] [] mEarlySecInfo <- case rtt0info of Nothing -> return Nothing Just info -> Just <$> getEarlySecretInfo info @@ -162,7 +179,6 @@ highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMainSecret $ ctxSupported ctx - groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations @@ -196,19 +212,21 @@ -------------------- + -- RFC 6066 Section 3: HostName is <1..2^16-1>, so no server_name + -- is sent for an empty name. sniExt = - if clientUseServerNameIndication cparams + if clientUseServerNameIndication cparams && not (null sni) then do - let sni = fst $ clientServerIdentification cparams usingState_ ctx $ setClientSNI sni return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing + where + sni = fst $ clientServerIdentification cparams - groupExt = - return $ - Just $ - toExtensionRaw $ - SupportedGroups (supportedGroups $ ctxSupported ctx) + -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond + -- to a group offered in the "supported_groups" extension and MUST + -- appear in the same order. + groupExt = return $ Just $ toExtensionRaw $ SupportedGroups grpsSupported ecPointExt = return $ @@ -244,11 +262,13 @@ Nothing -> return Nothing Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz - sessionTicketExt = do + sessionTicketExt = case clientSessions cparams of (sidOrTkt, _) : _ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt - _ -> return $ Just $ toExtensionRaw $ SessionTicket "" + _ + | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket "" + | otherwise -> return $ Nothing earlyDataExt | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) @@ -282,14 +302,20 @@ | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth | otherwise = return Nothing - -- FIXME keyShareExt - | tls13 = case groupToSend of - Nothing -> return Nothing - Just grp -> do - (cpri, ent) <- makeClientKeyShare ctx grp - usingHState ctx $ setGroupPrivate cpri - return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] + | tls13 = do + retried <- usingState_ ctx getTLS13HRR + mks <- usingState_ ctx getTLS13KeyShare + mch <- usingHState ctx getClientHello + case (retried, mks, mch) of + -- A HelloRetryRequest without key_share keeps the key shares. + (True, Nothing, Just (CH{chExtensions = exts}, _)) + | Just ext <- find (\(ExtensionRaw eid _) -> eid == EID_KeyShare) exts -> + return $ Just ext + _ -> do + (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected + usingHState ctx $ setGroupPrivate grpCpris + return $ Just $ toExtensionRaw $ KeyShareClientHello ents | otherwise = return Nothing secureRenegExt = @@ -304,60 +330,59 @@ | clientUseECH cparams = return $ Just $ toExtensionRaw ECHClientHelloInner | otherwise = return Nothing - preSharedKeyExt = - case pskInfo of - Nothing -> return Nothing - Just (identities, _, choice, obfAge) -> do - let zero = cZero choice - pskIdentities = map (\x -> PskIdentity x obfAge) identities - -- [zero] is a place holds. - -- adjustPreSharedKeyExt will replace them. - binders = replicate (length pskIdentities) zero - offeredPsks = PreSharedKeyClientHello pskIdentities binders - return $ Just $ toExtensionRaw offeredPsks + preSharedKeyExt + | null pskInfo = return Nothing + | otherwise = do + let pskIdentities = [PskIdentity x obfAge | (x, _, _, obfAge) <- pskInfo] + -- Zeros are place holders. + -- adjustPreSharedKeyExt will replace them. + binders = [convert $ cZero choice | (_, _, choice, _) <- pskInfo] + offeredPsks = PreSharedKeyClientHello pskIdentities binders + return $ Just $ toExtensionRaw offeredPsks randomPreSharedKeyExt :: IO (Maybe ExtensionRaw) - randomPreSharedKeyExt = - case pskInfo of - Nothing -> return Nothing - Just (identities, _, choice, _) -> do - let zero = cZero choice - zeroR <- getStdRandom $ uniformByteString $ B.length zero - obfAgeR <- getStdRandom genWord32 - let genPskId x = do - xR <- getStdRandom $ uniformByteString $ B.length x - return $ PskIdentity xR obfAgeR - pskIdentitiesR <- mapM genPskId identities - let bindersR = replicate (length pskIdentitiesR) zeroR - offeredPsksR = PreSharedKeyClientHello pskIdentitiesR bindersR - return $ Just $ toExtensionRaw offeredPsksR + randomPreSharedKeyExt + | null pskInfo = return Nothing + | otherwise = do + let genPsk (x, _, choice, _) = do + xR <- getStdRandom $ uniformByteString $ B.length x + obfAgeR <- getStdRandom genWord32 + zeroR <- getStdRandom $ uniformByteString $ BA.length $ cZero choice + return (PskIdentity xR obfAgeR, zeroR) + (pskIdentitiesR, bindersR) <- unzip <$> mapM genPsk pskInfo + let offeredPsksR = PreSharedKeyClientHello pskIdentitiesR bindersR + return $ Just $ toExtensionRaw offeredPsksR ---------------------------------------- - adjustPreSharedKeyExt exts ch = - case pskInfo of - Nothing -> return exts - Just (identities, sdata, choice, _) -> do - let psk = sessionSecret sdata - earlySecret = initEarlySecret choice (Just psk) - usingHState ctx $ setTLS13EarlySecret earlySecret - let ech = encodeHandshake $ ClientHello ch - h = cHash choice - siz = (hashDigestSize h + 1) * length identities + 2 - binder = makePSKBinder earlySecret h siz ech - -- PSK is shared by the previous TLS session. - -- So, PSK is unique for identities. - let binders = replicate (length identities) binder - let exts' = init exts ++ [adjust (last exts)] - adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders - where - withBinders = replacePSKBinder withoutBinders binders - return exts' + adjustPreSharedKeyExt exts ch + | null pskInfo = return exts + | otherwise = do + -- Each ticket has its own PSK, and so its own binder. + let earlySecrets = + [ initEarlySecret choice (Just $ sessionSecret sdata) + | (_, sdata, choice, _) <- pskInfo + ] + usingHState ctx $ setTLS13EarlySecrets earlySecrets + let ech = encodeHandshake $ ClientHello ch + siz = sum [hashDigestSize (cHash choice) + 1 | (_, _, choice, _) <- pskInfo] + 2 + binders <- + zipWithM + ( \earlySecret (_, _, choice, _) -> makePSKBinder ctx earlySecret (cHash choice) siz ech + ) + earlySecrets + pskInfo + let exts' = init exts ++ [adjust (last exts)] + adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders + where + withBinders = replacePSKBinder withoutBinders binders + return exts' getEarlySecretInfo choice = do let usedCipher = cCipher choice usedHash = cHash choice - Just earlySecret <- usingHState ctx getTLS13EarlySecret + -- Early data is protected with the first PSK. + earlySecret : _ <- usingHState ctx getTLS13EarlySecrets earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) let clientEarlySecret = pairClient earlyKey unless (ctxQUICMode ctx) $ do @@ -370,8 +395,10 @@ ---------------------------------------------------------------- +-- | The PSKs offered, each with its identity, session, cipher and +-- obfuscated ticket age; the cipher of early data; and whether to send it. type PreSharedKeyInfo = - ( Maybe ([SessionIDorTicket], SessionData, CipherChoice, Second) + ( [(SessionIDorTicket, SessionData, CipherChoice, Second)] , Maybe CipherChoice , Bool ) @@ -381,8 +408,19 @@ -> Context -> IO PreSharedKeyInfo getPreSharedKeyInfo cparams ctx = do - pskInfo <- getPskInfo - let rtt0info = pskInfo >>= get0RTTinfo + -- After HelloRetryRequest, the binders are computed with the hash of + -- the cipher it chose, so only the PSKs for that hash are offered. + hrr <- usingState_ ctx getTLS13HRR + mHrrCipher <- + if hrr then (>>= hstPendingCipher) <$> getHState ctx else return Nothing + pskInfo <- + if tls13 + then catMaybes <$> mapM (getPskEntry mHrrCipher) (clientSessions cparams) + else return [] + let rtt0info = case pskInfo of + (_, sdata, choice, _) : _ + | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 -> Just choice + _ -> Nothing rtt0 = isJust rtt0info return (pskInfo, rtt0info, rtt0) where @@ -390,35 +428,24 @@ highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 - sessions = case clientSessions cparams of - [] -> Nothing - (sid, sdata) : xs -> do - guard tls13 - guard (sessionVersion sdata >= TLS13) - let cid = sessionCipher sdata - sids = map fst xs - sCipher <- findCipher cid ciphers - Just (sid : sids, sdata, sCipher) - - getPskInfo = case sessions of - Nothing -> return Nothing - Just (identity, sdata, sCipher) -> do - let tinfo = fromJust $ sessionTicketInfo sdata - age <- getAge tinfo - return $ - if isAgeValid age tinfo - then - Just - ( identity - , sdata - , makeCipherChoice TLS13 sCipher - , ageToObfuscatedAge age tinfo - ) - else Nothing - - get0RTTinfo (_, sdata, choice, _) - | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 = Just choice - | otherwise = Nothing + getPskEntry mHrrCipher (identity, sdata) = case (sCipher, sessionTicketInfo sdata) of + (Just c, Just tinfo) + | sessionVersion sdata >= TLS13 + , maybe True (\hc -> cipherHash hc == cipherHash c) mHrrCipher -> do + age <- getAge tinfo + return $ + if isAgeValid age tinfo + then + Just + ( identity + , sdata + , makeCipherChoice TLS13 c + , ageToObfuscatedAge age tinfo + ) + else Nothing + _ -> return Nothing + where + sCipher = findCipher (sessionCipher sdata) ciphers ---------------------------------------------------------------- @@ -491,9 +518,13 @@ step2 (sniExtI@(ExtensionRaw EID_ServerName _) : exts) = (sniExtO : os, sniExtI : is) where - sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host] (os, is) = step3 exts id - step2 _ = error "step2" + -- No server_name for an empty name: only the outer one names the + -- public name. + step2 exts = (sniExtO : os, is) + where + (os, is) = step3 exts id + sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host] step3 [] build = ([], [echOuterExt]) where echOuterExt = toExtensionRaw $ EchOuterExtensions $ build [] @@ -511,6 +542,7 @@ -> (KDF_ID, AEAD_ID, ECHConfig) -> IO (Maybe (AAD -> PlainText -> IO CipherText, EncodedPublicKey, Int)) getHPKE ctx (kdfid, aeadid, conf) = do + nT <- maybe (E.throwIO $ Unsupported "AEAD") return $ nTag aeadid mfunc <- getTLS13HPKE ctx case mfunc of Nothing -> do @@ -524,7 +556,6 @@ where mpkR = cnfEncodedPublicKey conf kemid = cnfKemId conf - nT = nTag aeadid ---------------------------------------------------------------- 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 @@ -13,9 +13,10 @@ clientSessions, ) where -import Control.Exception (SomeException) +import qualified Control.Exception as E import Control.Monad.State.Strict -import Data.X509 (ExtKeyUsageFlag (..)) +import qualified Data.ByteString as B +import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS.Cipher import Network.TLS.Context.Internal @@ -38,7 +39,7 @@ ---------------------------------------------------------------- -throwMiscErrorOnException :: String -> SomeException -> IO a +throwMiscErrorOnException :: String -> E.SomeException -> IO a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e @@ -122,10 +123,15 @@ -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation - usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException + result <- catchException (Right <$> checkCert) (return . Left) + usage <- either rejectOnException (return . wrapCertificateChecks) result case usage of - CertificateUsageAccept -> checkLeafCertificateKeyUsage - CertificateUsageReject reason -> certificateRejected reason + CertificateUsageAccept -> do + verifyLeafKeyUsagePurpose [KeyUsagePurpose_ServerAuth] certs + verifyLeafKeySize (ctxSupported ctx) certs + checkLeafCertificateKeyUsage + CertificateUsageReject reason -> + certificateRejected ctx (either (const []) id result) certs reason where shared = clientShared cparams checkCert = @@ -177,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 @@ -196,7 +202,7 @@ sigAlgsToCertTypes :: Context - -> [HashAndSignatureAlgorithm] + -> [SignatureScheme] -> [CertificateType] sigAlgsToCertTypes ctx hashSigs = filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx @@ -304,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. @@ -314,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 @@ -342,14 +348,28 @@ (return ()) setAlpn where - setAlpn (ApplicationLayerProtocolNegotiation [proto]) = usingState_ ctx $ do - mprotos <- getClientALPNSuggest + setAlpn (ApplicationLayerProtocolNegotiation [proto]) = do + mprotos <- usingState_ ctx getClientALPNSuggest case mprotos of - Just protos -> when (proto `elem` protos) $ do - setExtensionALPN True - setNegotiatedProtocol proto - _ -> return () - setAlpn _ = return () + Nothing -> + throwCore $ + Error_Protocol + "server sent ALPN without a client offer" + UnsupportedExtension + Just protos + | not (B.null proto) && proto `elem` protos -> usingState_ ctx $ do + setExtensionALPN True + setNegotiatedProtocol proto + | otherwise -> + throwCore $ + Error_Protocol + "server selected an ALPN protocol not offered by the client" + IllegalParameter + setAlpn _ = + throwCore $ + Error_Protocol + "server ALPN response did not contain exactly one protocol" + IllegalParameter ---------------------------------------------------------------- @@ -357,7 +377,16 @@ contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync sync _ -> sync ctx ctl +-- RFC 9846 Section 4.6.1: a session is resumed only with the SNI it was +-- established with, which its server certificate is valid for. clientSessions :: ClientParams -> [(SessionID, SessionData)] -clientSessions ClientParams{..} = case clientWantSessionResume of - Nothing -> clientWantSessionResumeList - Just ent -> clientWantSessionResumeList ++ [ent] +clientSessions ClientParams{..} = filter sameSNI sessions + where + sessions = case clientWantSessionResume of + Nothing -> clientWantSessionResumeList + Just ent -> clientWantSessionResumeList ++ [ent] + host = fst clientServerIdentification + sni + | clientUseServerNameIndication && not (null host) = Just host + | otherwise = Nothing + sameSNI (_, sd) = sessionClientSNI sd == sni diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -4,8 +4,10 @@ module Network.TLS.Handshake.Client.ServerHello ( receiveServerHello, processServerHello13, + processRecordSizeLimit, ) where +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher @@ -20,7 +22,6 @@ import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.TranscriptHash -import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Parameters @@ -35,12 +36,12 @@ :: ClientParams -> Context -> Maybe (ClientRandom, Session, Version) - -> IO (Version, [Handshake], Bool) + -> IO (Version, [HandshakeR], Bool) receiveServerHello cparams ctx mparams = do chSentTime <- getCurrentTimeFromBase - (sh, hss) <- recvSH + (shb@(sh, _), hbs) <- recvSH processServerHello cparams ctx sh - void $ updateTranscriptHash12 ctx sh + updateTranscriptHash12 ctx shb setRTT ctx chSentTime ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $ @@ -51,15 +52,18 @@ -- False otherwise. For 2nd server hello, getTLS13HR returns -- False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR - return (ver, hss, hrr) + -- In TLS 1.3, ServerHello must end its record (RFC 9846 Section 5.1). + when (ver == TLS13 && not (null hbs)) $ + unexpected (show $ map fst hbs) Nothing + return (ver, hbs, hrr) where recvSH = do - epkt <- recvPacket12 ctx + epkt <- recvPacket12HS ctx case epkt of Left e -> throwCore e Right pkt -> case pkt of Alert a -> throwAlert a - Handshake (h : hs) -> return (h, hs) + Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs) _ -> unexpected (show pkt) (Just "handshake") throwAlert a = throwCore $ @@ -88,12 +92,13 @@ processServerHello :: ClientParams -> Context -> Handshake -> IO () processServerHello cparams ctx (ServerHello sh@SH{..}) = do - -- A server which receives a legacy_version value not equal to - -- 0x0303 MUST abort the handshake with an "illegal_parameter" - -- alert. + -- A client which receives a TLS 1.3 ServerHello with a legacy_version + -- value not equal to 0x0303 MUST abort the handshake with a + -- "protocol_version" alert (RFC 9846 Section 4.1.3). Nothing below + -- TLS 1.2 is supported either. when (shVersion /= TLS12) $ throwCore $ - Error_Protocol (show shVersion ++ " is not supported") IllegalParameter + Error_Protocol (show shVersion ++ " is not supported") ProtocolVersion -- find the compression and cipher methods that the server want to use. clientSession <- tls13stSession <$> getTLS13State ctx chExts <- tls13stSentExtensions <$> getTLS13State ctx @@ -119,6 +124,25 @@ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension + -- RFC 9846 Section 4.3.1: the version selected must be TLS 1.3 or + -- later, and offered. + let supportedVers = supportedVersions $ clientSupported cparams + selected (SupportedVersionsServerHello v) = Just v + selected _ = Nothing + case lookupAndDecode + EID_SupportedVersions + MsgTServerHello + shExtensions + Nothing + selected of + Just v + | v < TLS13 || v `notElem` supportedVers -> + throwCore $ + Error_Protocol + ("supported_versions selecting " ++ show v) + IllegalParameter + _ -> return () + let isHRR = isHelloRetryRequest shRandom usingState_ ctx $ do setTLS13HRR isHRR @@ -137,11 +161,37 @@ ver <- usingState_ ctx getVersion + -- TLS 1.2 without supported_versions, too, must be one we support. + when (ver `notElem` supportedVers) $ + throwCore $ + Error_Protocol + ("server version " ++ show ver ++ " is not supported") + ProtocolVersion + + -- RFC 9846 Section 4.2: an extension recognized but not specified for + -- the message is refused with illegal_parameter. + when (ver == TLS13) $ do + let allowed + | isHRR = + [EID_KeyShare, EID_SupportedVersions, EID_Cookie, EID_EncryptedClientHello] + | otherwise = [EID_KeyShare, EID_PreSharedKey, EID_SupportedVersions] + forbidden (ExtensionRaw eid _) = + eid `elem` supportedExtensions && eid `notElem` allowed + case filter forbidden shExtensions of + [] -> return () + ExtensionRaw eid _ : _ -> + throwCore $ + Error_Protocol (show eid ++ " is not allowed in ServerHello") IllegalParameter + + unless (cipherAllowedForVersion ver usedCipher) $ + throwCore $ + Error_Protocol + "server selected a cipher invalid for the negotiated version" + IllegalParameter + when (ver == TLS12) $ setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg - let supportedVers = supportedVersions $ clientSupported cparams - when (ver == TLS13) $ do -- TLS 1.3 server MUST echo the session id when (clientSession /= shSession) $ @@ -149,11 +199,6 @@ Error_Protocol "session is not matched in compatibility mode" IllegalParameter - when (ver `notElem` supportedVers) $ - throwCore $ - Error_Protocol - ("server version " ++ show ver ++ " is not supported") - ProtocolVersion -- Some servers set TLS 1.2 as the legacy server hello version, -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set @@ -172,14 +217,13 @@ then do -- Session is dummy in TLS 1.3. usingState_ ctx $ setSession shSession - processRecordSizeLimit ctx shExtensions True - enableMyRecordLimit ctx - enablePeerRecordLimit ctx + -- RecordSizeLimit comes in EncryptedExtensions in TLS 1.3 + -- (RFC 8449 Section 4), and is processed there. let usedHash = cipherHash usedCipher transitTranscriptHashI ctx "transitI" usedHash isHRR accepted <- checkECHacceptance ctx isHRR usedHash sh when accepted $ do - CH{..} <- fromJust <$> usingHState ctx getClientHello + (CH{..}, _b) <- fromJust <$> usingHState ctx getClientHello usingHState ctx $ setClientRandom chRandom -- inner random when (accepted && not isHRR) $ do copyTranscriptHash ctx "copy" @@ -245,7 +289,7 @@ when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent" in throwCore $ Error_Protocol err HandshakeFailure - let mainSecret = sessionSecret sessionData + let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret logKey ctx (MainSecret mainSecret) @@ -265,6 +309,10 @@ (return ()) (setPeerRecordSizeLimit ctx tls13) ack <- checkPeerRecordLimit ctx + -- RFC 8449 Section 4: a limit that is not negotiated does not + -- bind the peer, so a server that did not send RecordSizeLimit + -- back may send records of any size the protocol permits. + unless ack $ setMyRecordLimit ctx Nothing -- When a client sends RecordSizeLimit, it does not know -- which TLS version the server selects. RecordLimit is -- the length of plaintext. But RecordSizeLimit also diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs --- a/Network/TLS/Handshake/Client/TLS12.hs +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -8,6 +8,7 @@ ) where import Control.Monad.State.Strict +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher @@ -32,14 +33,15 @@ ---------------------------------------------------------------- -recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO () -recvServerFirstFlight12 cparams ctx hs = do +recvServerFirstFlight12 + :: ClientParams -> Context -> [HandshakeR] -> IO () +recvServerFirstFlight12 cparams ctx hbs = do resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do let st = RecvStateHandshake (expectCertificate cparams ctx) - runRecvStateHS ctx st hs + runRecvStateHS ctx st hbs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do @@ -47,13 +49,20 @@ doCertificate cparams ctx certs processCertificate ctx ClientRole certs return $ RecvStateHandshake (expectServerKeyExchange ctx) -expectCertificate _ ctx p = expectServerKeyExchange ctx p +-- Every key exchange the client implements authenticates the server with a +-- certificate; see sendClientKeyXchg. +expectCertificate _ _ p = unexpected (show p) (Just "server certificate") expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) expectServerKeyExchange ctx (ServerKeyXchg origSkx) = do doServerKeyExchange ctx origSkx return $ RecvStateHandshake (expectCertificateRequest ctx) -expectServerKeyExchange ctx p = expectCertificateRequest ctx p +expectServerKeyExchange ctx p = do + -- (EC)DHE takes its parameters from ServerKeyExchange. + kx <- cipherKeyExchange <$> usingHState ctx getPendingCipher + unless (kx == CipherKeyExchange_RSA) $ + unexpected (show p) (Just "server key exchange") + expectCertificateRequest ctx p expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO) expectCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do @@ -151,7 +160,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True - sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] + sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] [] ---------------------------------------------------------------- @@ -167,19 +176,19 @@ _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure - sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] + sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] [] mainSecret <- usingHState ctx setMainSec logKey ctx (MainSecret mainSecret) -------------------------------- getCKX_RSA - :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString) + :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_RSA ctx = do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 - let preMain = encodePreMainSecret clientVersion prerand + let preMain = convert $ encodePreMainSecret clientVersion prerand setMainSec = setMainSecretFromPre xver ClientRole preMain encryptedPreMain <- do -- SSL3 implementation generally forget this length field since it's redundant, @@ -194,7 +203,7 @@ getCKX_DHE :: ClientParams -> Context - -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString) + -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_DHE cparams ctx = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams @@ -203,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 @@ -241,12 +263,12 @@ -------------------------------- getCKX_ECDHE - :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString) + :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_ECDHE ctx = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setSupportedGroup grp - ecdhePair <- generateECDHEShared ctx srvpub + ecdhePair <- encapsulateGroup ctx srvpub case ecdhePair of Nothing -> throwCore $ @@ -254,7 +276,7 @@ Just (clipub, preMain) -> do xver <- usingState_ ctx getVersion let setMainSec = setMainSecretFromPre xver ClientRole preMain - return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec) + return (CKX_ECDH $ groupEncodePublicB clipub, setMainSec) ---------------------------------------------------------------- @@ -283,4 +305,4 @@ -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs - sendPacket12 ctx $ Handshake [CertVerify sigDig] + sendPacket12 ctx $ Handshake [CertVerify sigDig] [] diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -7,9 +7,9 @@ postHandshakeAuthClientWith, ) where -import Control.Exception (bracket) +import qualified Control.Exception as E import Control.Monad.State.Strict -import qualified Data.ByteString as B +import qualified Data.ByteArray as BA import Data.IORef import Network.TLS.Cipher @@ -39,7 +39,7 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -recvServerSecondFlight13 :: ClientParams -> Context -> Maybe Group -> IO () +recvServerSecondFlight13 :: ClientParams -> Context -> [Group] -> IO () recvServerSecondFlight13 cparams ctx groupSent = do resuming <- prepareSecondFlight13 ctx groupSent runRecvHandshake13 $ do @@ -50,14 +50,14 @@ ---------------------------------------------------------------- prepareSecondFlight13 - :: Context -> Maybe Group -> IO Bool + :: Context -> [Group] -> IO Bool prepareSecondFlight13 ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher prepareSecondFlight13' ctx groupSent choice prepareSecondFlight13' :: Context - -> Maybe Group + -> [Group] -> CipherChoice -> IO Bool prepareSecondFlight13' ctx groupSent choice = do @@ -100,59 +100,92 @@ "key exchange not implemented, expected key_share extension" HandshakeFailure let grp = keyShareEntryGroup serverKeyShare - unless (checkKeyShareKeyLength serverKeyShare) $ + unless (checkServerKeyShareKeyLength serverKeyShare) $ throwCore $ Error_Protocol "broken key_share" IllegalParameter - unless (groupSent == Just grp) $ + unless (grp `elem` groupSent) $ throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter usingHState ctx $ setSupportedGroup grp usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare makeEarlySecret = do - mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret - case mEarlySecretPSK of + earlySecrets <- usingHState ctx getTLS13EarlySecrets + mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey + case mSelectedIdentity of Nothing -> return (initEarlySecret choice Nothing, False) - Just earlySecretPSK@(BaseSecret sec) -> do - mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey - case mSelectedIdentity of - Nothing -> - return (initEarlySecret choice Nothing, False) - Just (PreSharedKeyServerHello 0) -> do - unless (B.length sec == hashSize) $ - throwCore $ - Error_Protocol - "selected cipher is incompatible with selected PSK" - IllegalParameter - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - return (earlySecretPSK, True) - Just _ -> - throwCore $ Error_Protocol "selected identity out of range" IllegalParameter + Just (PreSharedKeyServerHello n) + | n >= 0 + , earlySecretPSK@(BaseSecret sec) : _ <- drop n earlySecrets -> do + unless (BA.length sec == hashSize) $ + throwCore $ + Error_Protocol + "selected cipher is incompatible with selected PSK" + IllegalParameter + usingHState ctx $ setTLS13HandshakeMode PreSharedKey + return (earlySecretPSK, True) + Just _ -> + throwCore $ Error_Protocol "selected identity out of range" IllegalParameter ---------------------------------------------------------------- expectEncryptedExtensions :: MonadIO m => Context -> Handshake13 -> m () expectEncryptedExtensions ctx (EncryptedExtensions13 eexts) = do + -- RFC 9846 Section 4.2: an extension recognized but not specified for + -- EncryptedExtensions is refused with illegal_parameter. + let allowed = + [ EID_ServerName + , EID_SupportedGroups + , EID_ApplicationLayerProtocolNegotiation + , EID_RecordSizeLimit + , EID_EarlyData + , EID_QuicTransportParameters + , EID_EncryptedClientHello + ] + forbidden (ExtensionRaw eid _) = + eid `elem` supportedExtensions && eid `notElem` allowed + case filter forbidden eexts of + [] -> return () + ExtensionRaw eid _ : _ -> + throwCore $ + Error_Protocol + (show eid ++ " is not allowed in EncryptedExtensions") + IllegalParameter liftIO $ do + -- RFC 8449 Section 4: the server's RecordSizeLimit is in + -- EncryptedExtensions. Until it is known, our own limit is not + -- enforced, as the server may not have agreed to it. + processRecordSizeLimit ctx eexts True + enableMyRecordLimit ctx + enablePeerRecordLimit ctx setALPN ctx MsgTEncryptedExtensions eexts modifyTLS13State ctx $ \st -> st{tls13stClientExtensions = eexts} st13 <- usingHState ctx getTLS13RTT0Status when (st13 == RTT0Sent) $ case extensionLookup EID_EarlyData eexts of Just _ -> do + -- RFC 8446 Section 4.2.10: early data is accepted only + -- with the first PSK. + mode <- usingHState ctx getTLS13HandshakeMode + unless (mode == PreSharedKey) $ + throwCore $ + Error_Protocol "early data accepted without PSK" IllegalParameter + selected <- liftIO $ usingState_ ctx getTLS13PreSharedKey + unless (selected == Just (PreSharedKeyServerHello 0)) $ + throwCore $ + Error_Protocol "early data accepted without the first PSK" IllegalParameter usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted liftIO $ modifyTLS13State ctx $ \st -> st{tls13st0RTTAccepted = True} - Nothing -> do - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - usingHState ctx $ setTLS13RTT0Status RTT0Rejected -expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions") + Nothing -> usingHState ctx $ setTLS13RTT0Status RTT0Rejected +expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ---------------------------------------------------------------- -- not used in 0-RTT expectCertRequest - :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () + :: MonadIO m + => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertRequest cparams ctx (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx $ expectCertAndVerify cparams ctx @@ -205,37 +238,45 @@ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure unsighash :: SignatureAlgorithms - -> Maybe [HashAndSignatureAlgorithm] + -> Maybe [SignatureScheme] unsighash (SignatureAlgorithms a) = Just a ---------------------------------------------------------------- -- not used in 0-RTT expectCertAndVerify - :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () + :: MonadIO m + => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc -expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate") +expectCertAndVerify _ _ h = unexpected (show h) (Just "server certificate") processCertAndVerify :: MonadIO m => ClientParams -> Context -> CertificateChain -> RecvHandshake13M m () processCertAndVerify cparams ctx cc = do + pubkey <- processServerCertificate cparams ctx cc + recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey + +processServerCertificate + :: MonadIO m => ClientParams -> Context -> CertificateChain -> m PubKey +processServerCertificate cparams ctx cc = do liftIO $ usingState_ ctx $ setServerCertificateChain cc liftIO $ doCertificate cparams ctx cc let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey - recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey + return pubkey ---------------------------------------------------------------- expectCertVerify - :: MonadIO m => Context -> PubKey -> TranscriptHash -> Handshake13 -> m () + :: MonadIO m + => Context -> PubKey -> TranscriptHash -> Handshake13 -> m () expectCertVerify ctx pubkey (TranscriptHash hChSc) (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" -expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify") +expectCertVerify _ _ _ h = unexpected (show h) (Just "certificate verify") ---------------------------------------------------------------- @@ -290,7 +331,7 @@ runPacketFlight ctx $ sendChangeCipherSpec13 ctx when (rtt0accepted && not (ctxQUICMode ctx)) $ - sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) + sendPacket13 ctx (Handshake13 [EndOfEarlyData13] []) let clientHandshakeSecret = triClient hkey setTxRecordState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret @@ -328,7 +369,7 @@ {- Unused for now uncertsig :: SignatureAlgorithmsCert - -> Maybe [HashAndSignatureAlgorithm] + -> Maybe [SignatureScheme] uncertsig (SignatureAlgorithmsCert a) = Just a -} @@ -344,7 +385,7 @@ certComp <- usingHState ctx getTLS13CertComp loadClientData13 cc reqtoken certComp rawFinished <- makeFinished ctx usedHash baseKey - loadPacket13 ctx $ Handshake13 [rawFinished] + loadPacket13 ctx $ Handshake13 [rawFinished] [] when (isJust mcc) $ modifyTLS13State ctx $ \st -> st{tls13stSentClientCert = True} @@ -355,7 +396,7 @@ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx let certtag = if certComp then CompressedCertificate13 else Certificate13 loadPacket13 ctx $ - Handshake13 [certtag token (CertificateChain_ chain) certExts] + Handshake13 [certtag token (CertificateChain_ chain) certExts] [] case certs of [] -> return () _ -> do @@ -364,7 +405,7 @@ sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc - loadPacket13 ctx $ Handshake13 [vfy] + loadPacket13 ctx $ Handshake13 [vfy] [] -- loadClientData13 _ _ _ = throwCore $ @@ -373,10 +414,14 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () -postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = - bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do - void $ updateTranscriptHash13 ctx h +postHandshakeAuthClientWith + :: ClientParams -> Context -> Handshake13R -> IO () +postHandshakeAuthClientWith cparams ctx hb@(CertRequest13 certReqCtx exts, _) = + E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do + -- RFC 8446 Section 4.4: the handshake context of + -- post-handshake authentication is ClientHello ... client + -- Finished + CertificateRequest. + updateTranscriptHash13 ctx hb processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $ @@ -399,20 +444,46 @@ ---------------------------------------------------------------- asyncServerHello13 - :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO () + :: ClientParams -> Context -> [Group] -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx - [ PendingRecvAction True False expectServerHello - , PendingRecvAction True True (expectEncryptedExtensions ctx) - , PendingRecvActionHash True expectFinishedAndSet - ] + [PendingRecvActionSelfUpdate True expectServerHello] where - expectServerHello sh = do + expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh - void $ updateTranscriptHash13 ctx sh -- update by myself - void $ prepareSecondFlight13 ctx groupSent + updateTranscriptHash13 ctx shb -- update by myself + resuming <- prepareSecondFlight13 ctx groupSent + -- Without the PSK, the server authenticates with its certificate, + -- as in recvServerSecondFlight13. + setPendingRecvActions ctx $ + if resuming + then + [ PendingRecvAction False (expectEncryptedExtensions ctx) + , PendingRecvActionHash True expectFinishedAndSet + ] + else + [ PendingRecvAction False (expectEncryptedExtensions ctx) + , PendingRecvAction False expectCertRequestAsync + , PendingRecvActionHash True expectFinishedAndSet + ] + -- The actions below put the next one in front of Finished. + expectCertRequestAsync (CertRequest13 token exts) = do + processCertRequest13 ctx token exts + pushPendingRecvAction ctx $ PendingRecvAction False expectCertAsync + expectCertRequestAsync h = do + usingHState ctx $ do + setCertReqToken Nothing + setCertReqCBdata Nothing + expectCertAsync h + expectCertAsync (Certificate13 _ (CertificateChain_ cc) _) = certAsync cc + expectCertAsync (CompressedCertificate13 _ (CertificateChain_ cc) _) = certAsync cc + expectCertAsync h = unexpected (show h) (Just "server certificate") + certAsync cc = do + pubkey <- processServerCertificate cparams ctx cc + pushPendingRecvAction ctx $ + PendingRecvActionHash False (expectCertVerify ctx pubkey) expectFinishedAndSet h sf = do expectFinished cparams ctx h sf liftIO $ 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 @@ -17,10 +17,13 @@ runRecvState, runRecvStateHS, recvPacketHandshake, + recvPacket12HS, onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret, getSessionData, + clientLeafCertificate, + restoreClientCertificate, storePrivInfo, isSupportedGroup, checkSupportedGroup, @@ -31,6 +34,7 @@ -- setPeerRecordSizeLimit, generateFinished, + encodeUpdateTranscriptHash12, updateTranscriptHash12, -- startHandshake, @@ -39,9 +43,12 @@ ) where import Control.Concurrent.MVar -import Control.Exception (IOException, fromException, handle, throwIO) +import qualified Control.Exception as E import Control.Monad.State.Strict +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 @@ -67,7 +74,7 @@ import Network.TLS.X509 handshakeFailed :: TLSError -> IO () -handshakeFailed err = throwIO $ HandshakeFailed err +handshakeFailed err = E.throwIO $ HandshakeFailed err handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do @@ -75,12 +82,12 @@ -- If the error was an Uncontextualized TLSException, we replace the -- context with HandshakeFailed. If it's anything else, we convert -- it to a string and wrap it with Error_Misc and HandshakeFailed. - let tlserror = case fromException exception of + let tlserror = case E.fromException exception of Just e | Uncontextualized e' <- e -> e' _ -> Error_Misc (show exception) established <- ctxEstablished ctx setEstablished ctx NotEstablished - handle ignoreIOErr $ do + E.handle ignoreIOErr $ do tls13 <- tls13orLater ctx if tls13 then do @@ -91,7 +98,7 @@ else sendPacket12 ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where - ignoreIOErr :: IOException -> IO () + ignoreIOErr :: E.IOException -> IO () ignoreIOErr _ = return () errorToAlert :: TLSError -> (AlertLevel, AlertDescription) @@ -101,6 +108,11 @@ errorToAlert (Error_Packet_Parsing msg) | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion) | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter) + | "cannot be decompressed" `isInfixOf` msg = (AlertLevel_Fatal, BadCertificate) + | "error certificate parsing" `isInfixOf` msg = + (AlertLevel_Fatal, BadCertificate) + | "unsupported certificate compression algorithm" `isInfixOf` msg = + (AlertLevel_Fatal, IllegalParameter) | otherwise = (AlertLevel_Fatal, DecodeError) errorToAlert _ = (AlertLevel_Fatal, InternalError) @@ -132,7 +144,7 @@ enablePeerRecordLimit ctx ver <- usingState_ ctx getVersion verifyData <- VerifyData <$> generateFinished ctx ver role - sendPacket12 ctx (Handshake [Finished verifyData]) + sendPacket12 ctx (Handshake [Finished verifyData] []) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx @@ -141,36 +153,62 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake] +-- | 'recvPacket12' during a TLS 1.2 handshake. A client ignores +-- HelloRequest while negotiating (RFC 5246 Section 7.4.1.1), and +-- application data under the current keys may come during renegotiation +-- (Section 6.2.1); it is kept for 'recvData'. +recvPacket12HS :: Context -> IO (Either TLSError Packet) +recvPacket12HS ctx = do + pkt <- recvPacket12 ctx + role <- usingState_ ctx getRole + case pkt of + Right (Handshake hss bss) + | role == ClientRole && any isHelloRequest hss -> + case unzip $ filter (not . isHelloRequest . fst) $ zip hss bss of + ([], _) -> recvPacket12HS ctx + (hss', bss') -> return $ Right $ Handshake hss' bss' + Right (AppData x) -> do + established <- ctxEstablished ctx + switched <- maybe False hstRxSwitched <$> getHState ctx + if established == Established && not switched + then do + modifyIORef' (ctxPendingAppData ctx) (x :) + recvPacket12HS ctx + else return pkt + _ -> return pkt + where + isHelloRequest HelloRequest = True + isHelloRequest _ = False + +recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do - pkts <- recvPacket12 ctx + pkts <- recvPacket12HS ctx case pkts of - Right (Handshake l) -> return l - Right x@(AppData _) -> do - -- If a TLS13 server decides to reject RTT0 data, the server should - -- skip records for RTT0 data up to the maximum limit. - established <- ctxEstablished ctx - case established of - EarlyDataNotAllowed n - | n > 0 -> do - setEstablished ctx $ EarlyDataNotAllowed (n - 1) - recvPacketHandshake ctx - _ -> unexpected (show x) (Just "handshake") + Right (Handshake hss bss) -> return $ zip hss bss + Right x@(AppData bs) -> do + -- A TLS 1.3 server that sent HelloRetryRequest skips early data + -- until the second ClientHello (RFC 9846 Section 4.2.10). + skipped <- skipEarlyData ctx (B.length bs) + if skipped + then recvPacketHandshake ctx + else unexpected (show x) (Just "handshake") Right x -> unexpected (show x) (Just "handshake") Left err -> throwCore err -- | process a list of handshakes message in the recv state machine. onRecvStateHandshake - :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO) + :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO) onRecvStateHandshake _ recvState [] = return recvState -onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms) -onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do - let finished = isFinished x - unless finished $ void $ updateTranscriptHash12 ctx x - nstate <- f x - when finished $ void $ updateTranscriptHash12 ctx x - onRecvStateHandshake ctx nstate xs -onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing +onRecvStateHandshake _ (RecvStatePacket f) hbs = do + let (hss, bss) = unzip hbs + f (Handshake hss bss) +onRecvStateHandshake ctx (RecvStateHandshake f) (hb@(h, _) : hbs) = do + let finished = isFinished h + unless finished $ void $ updateTranscriptHash12 ctx hb + nstate <- f h + when finished $ void $ updateTranscriptHash12 ctx hb + onRecvStateHandshake ctx nstate hbs +onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing isFinished :: Handshake -> Bool isFinished Finished{} = True @@ -178,14 +216,15 @@ runRecvState :: Context -> RecvState IO -> IO () runRecvState _ RecvStateDone = return () -runRecvState ctx (RecvStatePacket f) = recvPacket12 ctx >>= either throwCore f >>= runRecvState ctx +runRecvState ctx (RecvStatePacket f) = recvPacket12HS ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx -runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO () -runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx +runRecvStateHS + :: Context -> RecvState IO -> [HandshakeR] -> IO () +runRecvStateHS ctx iniState hbs = onRecvStateHandshake ctx iniState hbs >>= runRecvState ctx ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do @@ -219,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 @@ -227,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 @@ -239,12 +297,14 @@ , sessionCipher = cipher , sessionCompression = compression , sessionClientSNI = sni - , sessionSecret = ms + , sessionSecret = convert ms , sessionGroup = Nothing , sessionTicketInfo = Nothing , sessionALPN = alpn , sessionMaxEarlyDataSize = 0 , sessionFlags = flags + , sessionClientCertificate = clientCert + , sessionAppData = Nothing } -- | Store the specified keypair. Whether the public key and private key @@ -359,15 +419,15 @@ generateServerFinished ver cipher mainSecret thash generateFinished' - :: PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString -generateFinished' prf label mainSecret (TranscriptHash thash) = prf mainSecret seed 12 + :: PRF -> ByteString -> Secret -> TranscriptHash -> ByteString +generateFinished' prf label mainSecret (TranscriptHash thash) = convert $ prf mainSecret seed 12 where seed = label <> thash generateClientFinished :: Version -> Cipher - -> ByteString + -> Secret -> TranscriptHash -> ByteString generateClientFinished ver ciph = @@ -376,7 +436,7 @@ generateServerFinished :: Version -> Cipher - -> ByteString + -> Secret -> TranscriptHash -> ByteString generateServerFinished ver ciph = @@ -431,6 +491,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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -36,7 +37,8 @@ calculateApplicationSecret, calculateResumptionSecret, derivePSK, - checkKeyShareKeyLength, + checkClientKeyShareKeyLength, + checkServerKeyShareKeyLength, setRTT, computeConfirm, updateTranscriptHash13, @@ -46,7 +48,7 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict -import qualified Data.ByteArray as BA +import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.UnixTime import Foreign.C.Types (CTime (..)) @@ -58,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 @@ -68,7 +70,6 @@ import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC -import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State @@ -79,7 +80,7 @@ ---------------------------------------------------------------- -makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13 +makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13 makeFinished ctx usedHash baseKey = do verifyData <- VerifyData . makeVerifyData usedHash baseKey @@ -89,7 +90,7 @@ checkFinished :: MonadIO m - => Context -> Hash -> ByteString -> TranscriptHash -> VerifyData -> m () + => Context -> Hash -> Secret -> TranscriptHash -> VerifyData -> m () checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash hashValue when (B.length verifyData /= B.length verifyData') $ @@ -98,7 +99,7 @@ unless (verifyData' == verifyData) $ decryptError "finished verification failed" liftIO $ usingState_ ctx $ setVerifyDataForRecv vd -makeVerifyData :: Hash -> ByteString -> TranscriptHash -> ByteString +makeVerifyData :: Hash -> Secret -> TranscriptHash -> ByteString makeVerifyData usedHash baseKey (TranscriptHash th) = hmac usedHash finishedKey th where @@ -107,38 +108,41 @@ ---------------------------------------------------------------- -makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry) +makeClientKeyShare + :: Context -> Group -> IO ((Group, IES.GroupPrivate), KeyShareEntry) +makeClientKeyShare ctx grp = do + (cpri, cpub) <- generateGroup ctx grp + let wcpub = IES.groupEncodePublicA cpub + clientKeyShare = KeyShareEntry grp wcpub + return ((grp, cpri), clientKeyShare) + +makeServerKeyShare :: Context -> KeyShareEntry -> IO (Secret, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter Right cpub -> do - ecdhePair <- generateECDHEShared ctx cpub + ecdhePair <- encapsulateGroup ctx cpub case ecdhePair of Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter Just (spub, share) -> - let wspub = IES.encodeGroupPublic spub + let wspub = IES.groupEncodePublicB spub serverKeyShare = KeyShareEntry grp wspub - in return (BA.convert share, serverKeyShare) + in return (share, serverKeyShare) where - ecpub = IES.decodeGroupPublic grp wcpub + ecpub = IES.groupDecodePublicA grp wcpub msgInvalidPublic = "invalid client " ++ show grp ++ " public key" -makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry) -makeClientKeyShare ctx grp = do - (cpri, cpub) <- generateECDHE ctx grp - let wcpub = IES.encodeGroupPublic cpub - clientKeyShare = KeyShareEntry grp wcpub - return (cpri, clientKeyShare) - -fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString -fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of +fromServerKeyShare + :: KeyShareEntry -> [(Group, IES.GroupPrivate)] -> IO Secret +fromServerKeyShare (KeyShareEntry grp wspub) grpCpris = case espub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter - Right spub -> case IES.groupGetShared spub cpri of - Just shared -> return $ BA.convert shared - Nothing -> - throwCore $ - Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter + Right spub -> case lookup grp grpCpris of + Nothing -> throwCore err + Just cpri -> case IES.groupDecapsulate spub cpri of + Just shared -> return shared + Nothing -> throwCore err where - espub = IES.decodeGroupPublic grp wspub + err = Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter + espub = IES.groupDecodePublicB grp wspub ---------------------------------------------------------------- @@ -152,7 +156,7 @@ :: MonadIO m => Context -> PubKey - -> HashAndSignatureAlgorithm + -> SignatureScheme -> TranscriptHash -> m Handshake13 makeCertVerify ctx pub hs (TranscriptHash hashValue) = do @@ -161,28 +165,38 @@ | 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 -checkCertVerify ctx pub hs signature hashValue - | pub `signatureCompatible13` hs = liftIO $ do - role <- usingState_ ctx getRole - let ctxStr - | role == ClientRole = serverContextString -- opposite context - | otherwise = clientContextString - target = makeTarget ctxStr hashValue - sigParams = signatureParams pub hs - checkHashSignatureValid13 hs - checkSupportedHashSignature ctx hs - verifyPublic ctx sigParams target signature - | otherwise = return False +-- RFC 8446 Section 6.2: an algorithm that may not be used -- one TLS 1.3 +-- does not allow, one not offered, or one that does not fit the key -- is a +-- field that is incorrect, an illegal_parameter. Only a signature that does +-- not verify is a decrypt_error, which False leads to. +checkCertVerify ctx pub hs signature hashValue = liftIO $ do + checkHashSignatureValid13 hs + checkSupportedHashSignature ctx hs + unless (pub `signatureCompatible13` hs) $ + throwCore $ + Error_Protocol + ("signature algorithm " ++ show hs ++ " does not fit the public key") + IllegalParameter + role <- usingState_ ctx getRole + let ctxStr + | role == ClientRole = serverContextString -- opposite context + | otherwise = clientContextString + target = makeTarget ctxStr hashValue + sigParams = signatureParams pub hs + 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 @@ -195,7 +209,7 @@ :: MonadIO m => Context -> PubKey - -> HashAndSignatureAlgorithm + -> SignatureScheme -> ByteString -> m Signature sign ctx pub hs target = liftIO $ do @@ -205,17 +219,25 @@ ---------------------------------------------------------------- +-- | RFC 8446 Section 4.2.11.2: the binder covers the transcript up to the +-- truncated ClientHello, which after HelloRetryRequest begins with +-- message_hash(ClientHello1) and the HelloRetryRequest. makePSKBinder - :: BaseSecret EarlySecret + :: Context + -> BaseSecret EarlySecret -> Hash -> Int -> ByteString -- ^ Encoded client hello - -> ByteString -makePSKBinder (BaseSecret sec) usedHash truncLen ech = - makeVerifyData usedHash binderKey hChTruncated + -> IO ByteString +makePSKBinder ctx (BaseSecret sec) usedHash truncLen ech = do + hrr <- usingState_ ctx getTLS13HRR + hChTruncated <- + if hrr + then transcriptHashWith ctx "binder" $ trunc ech + else return $ TranscriptHash $ hash usedHash $ trunc ech + return $ makeVerifyData usedHash binderKey hChTruncated where - hChTruncated = TranscriptHash $ hash usedHash $ trunc ech th = TranscriptHash $ hash usedHash "" binderKey = deriveSecret usedHash sec "res binder" th trunc x = B.take takeLen x @@ -345,6 +367,7 @@ malpn <- usingState_ ctx getNegotiatedProtocol sni <- usingState_ ctx getClientSNI mgrp <- usingHState ctx getSupportedGroup + clientCert <- clientLeafCertificate ctx return SessionData { sessionVersion = ver @@ -357,6 +380,8 @@ , sessionALPN = malpn , sessionMaxEarlyDataSize = maxSize , sessionFlags = [] + , sessionClientCertificate = clientCert + , sessionAppData = Nothing } ---------------------------------------------------------------- @@ -373,7 +398,8 @@ ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a) +newtype RecvHandshake13M m a + = RecvHandshake13M (StateT [Handshake13R] m a) deriving (Functor, Applicative, Monad, MonadIO) recvHandshake13 @@ -381,7 +407,7 @@ => Context -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a -recvHandshake13 ctx f = getHandshake13 ctx >>= f +recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h recvHandshake13hash :: MonadIO m @@ -391,21 +417,22 @@ -> RecvHandshake13M m a recvHandshake13hash ctx label f = do d <- transcriptHash ctx label - getHandshake13 ctx >>= f d + getHandshake13 ctx >>= \(h, _b) -> f d h -getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13 +getHandshake13 + :: MonadIO m => Context -> RecvHandshake13M m Handshake13R getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of - (h : hs) -> found h hs - [] -> recvLoop + hb : hbs -> found hb hbs + _ -> recvLoop where - found h hs = liftIO (void $ updateTranscriptHash13 ctx h) >> put hs >> return h + found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of - Right (Handshake13 []) -> error "invalid recvPacket13 result" - Right (Handshake13 (h : hs)) -> found h hs + Right (Handshake13 [] _) -> error "invalid recvPacket13 result" + Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs Right ChangeCipherSpec13 -> do alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv if alreadyReceived @@ -428,32 +455,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: " ++ 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 @@ -462,11 +472,11 @@ -> Either ByteString (BaseSecret EarlySecret) -> IO (SecretPair EarlySecret) calculateEarlySecret ctx choice maux = do - ch <- fromJust <$> usingHState ctx getClientHello - let hCh = TranscriptHash $ hash usedHash $ encodeHandshake $ ClientHello ch + (_ch, b) <- fromJust <$> usingHState ctx getClientHello + let hCh = TranscriptHash $ hashChunks usedHash b let earlySecret = case maux of Right (BaseSecret sec) -> sec - Left psk -> hkdfExtract usedHash zero psk + Left psk -> hkdfExtract usedHash zero (convert psk) clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets @@ -481,13 +491,13 @@ sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice - zeroOrPSK = fromMaybe zero mpsk + zeroOrPSK = fromMaybe zero (convert <$> mpsk) calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret - -> ByteString + -> Secret -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do hChSh <- transcriptHash ctx "CH..SH" @@ -526,6 +536,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 @@ -561,25 +572,60 @@ ---------------------------------------------------------------- -checkKeyShareKeyLength :: KeyShareEntry -> Bool -checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key +checkClientKeyShareKeyLength :: KeyShareEntry -> Bool +checkClientKeyShareKeyLength ks = clientKeyShareKeyLength grp == B.length key where grp = keyShareEntryGroup ks key = keyShareEntryKeyExchange ks -keyShareKeyLength :: Group -> Int -keyShareKeyLength P256 = 65 -- 32 * 2 + 1 -keyShareKeyLength P384 = 97 -- 48 * 2 + 1 -keyShareKeyLength P521 = 133 -- 66 * 2 + 1 -keyShareKeyLength X25519 = 32 -keyShareKeyLength X448 = 56 -keyShareKeyLength FFDHE2048 = 256 -keyShareKeyLength FFDHE3072 = 384 -keyShareKeyLength FFDHE4096 = 512 -keyShareKeyLength FFDHE6144 = 768 -keyShareKeyLength FFDHE8192 = 1024 -keyShareKeyLength _ = error "keyShareKeyLength" +{- FOURMOLU_DISABLE -} +clientKeyShareKeyLength :: Group -> Int +clientKeyShareKeyLength P256 = 65 -- 32 * 2 + 1 +clientKeyShareKeyLength P384 = 97 -- 48 * 2 + 1 +clientKeyShareKeyLength P521 = 133 -- 66 * 2 + 1 +clientKeyShareKeyLength X25519 = 32 +clientKeyShareKeyLength X448 = 56 +clientKeyShareKeyLength FFDHE2048 = 256 +clientKeyShareKeyLength FFDHE3072 = 384 +clientKeyShareKeyLength FFDHE4096 = 512 +clientKeyShareKeyLength FFDHE6144 = 768 +clientKeyShareKeyLength FFDHE8192 = 1024 +clientKeyShareKeyLength MLKEM512 = 800 +clientKeyShareKeyLength MLKEM768 = 1184 +clientKeyShareKeyLength MLKEM1024 = 1568 +clientKeyShareKeyLength X25519MLKEM768 = 1216 +clientKeyShareKeyLength P256MLKEM768 = 1249 +clientKeyShareKeyLength P384MLKEM1024 = 1665 +clientKeyShareKeyLength _ = error "clientKeyShareKeyLength" +{- FOURMOLU_ENABLE -} +checkServerKeyShareKeyLength :: KeyShareEntry -> Bool +checkServerKeyShareKeyLength ks = serverKeyShareKeyLength grp == B.length key + where + grp = keyShareEntryGroup ks + key = keyShareEntryKeyExchange ks + +{- FOURMOLU_DISABLE -} +serverKeyShareKeyLength :: Group -> Int +serverKeyShareKeyLength P256 = 65 -- 32 * 2 + 1 +serverKeyShareKeyLength P384 = 97 -- 48 * 2 + 1 +serverKeyShareKeyLength P521 = 133 -- 66 * 2 + 1 +serverKeyShareKeyLength X25519 = 32 +serverKeyShareKeyLength X448 = 56 +serverKeyShareKeyLength FFDHE2048 = 256 +serverKeyShareKeyLength FFDHE3072 = 384 +serverKeyShareKeyLength FFDHE4096 = 512 +serverKeyShareKeyLength FFDHE6144 = 768 +serverKeyShareKeyLength FFDHE8192 = 1024 +serverKeyShareKeyLength MLKEM512 = 768 +serverKeyShareKeyLength MLKEM768 = 1088 +serverKeyShareKeyLength MLKEM1024 = 1568 +serverKeyShareKeyLength X25519MLKEM768 = 1120 +serverKeyShareKeyLength P256MLKEM768 = 1153 +serverKeyShareKeyLength P384MLKEM1024 = 1665 +serverKeyShareKeyLength _ = error "clientKeyShareKeyLength" +{- FOURMOLU_ENABLE -} + setRTT :: Context -> Millisecond -> IO () setRTT ctx chSentTime = do shRecvTime <- getCurrentTimeFromBase @@ -591,11 +637,11 @@ :: (MonadFail m, MonadIO m) => Context -> Hash -> ServerHello -> ByteString -> m ByteString computeConfirm ctx usedHash sh label = do - CH{..} <- fromJust <$> liftIO (usingHState ctx getClientHello) + (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello) TranscriptHash echConf <- transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh let prk = hkdfExtract usedHash "" $ unClientRandom chRandom - return $ hkdfExpandLabel usedHash prk label echConf 8 + return $ hkdfExpandLabel usedHash (convert prk) label echConf 8 ---------------------------------------------------------------- @@ -643,6 +689,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/Control.hs b/Network/TLS/Handshake/Control.hs --- a/Network/TLS/Handshake/Control.hs +++ b/Network/TLS/Handshake/Control.hs @@ -7,6 +7,7 @@ NegotiatedProtocol, ) where +import Crypto.Debug (DebugShow (..)) import Network.TLS.Cipher import Network.TLS.Imports import Network.TLS.Struct @@ -19,17 +20,40 @@ type NegotiatedProtocol = ByteString -- | Handshake information generated for traffic at 0-RTT level. +-- +-- 'Show' renders the cipher and @\@ for the key material; a trace +-- of what 'Network.TLS.QUIC.quicInstallKeys' is handed does not write the +-- traffic secrets to a log. 'Crypto.Debug.debugShow' renders them. data EarlySecretInfo = EarlySecretInfo Cipher (ClientTrafficSecret EarlySecret) deriving (Show) +instance DebugShow EarlySecretInfo where + debugShow (EarlySecretInfo c s) = + "EarlySecretInfo " ++ show c ++ " " ++ debugShow s + -- | Handshake information generated for traffic at handshake level. +-- +-- The secrets are not shown; see 'EarlySecretInfo'. data HandshakeSecretInfo = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret) deriving (Show) +instance DebugShow HandshakeSecretInfo where + debugShow (HandshakeSecretInfo c ts) = + "HandshakeSecretInfo " ++ show c ++ " " ++ debugShowPair ts + -- | Handshake information generated for traffic at application level. +-- +-- The secrets are not shown; see 'EarlySecretInfo'. newtype ApplicationSecretInfo = ApplicationSecretInfo (TrafficSecrets ApplicationSecret) deriving (Show) + +instance DebugShow ApplicationSecretInfo where + debugShow (ApplicationSecretInfo ts) = + "ApplicationSecretInfo " ++ debugShowPair ts + +debugShowPair :: TrafficSecrets a -> String +debugShowPair (c, s) = "(" ++ debugShow c ++ "," ++ debugShow s ++ ")" ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -7,8 +7,8 @@ decryptRSA, verifyPublic, generateDHE, - generateECDHE, - generateECDHEShared, + generateGroup, + encapsulateGroup, generateFFDHE, generateFFDHEShared, versionCompatible, @@ -20,6 +20,7 @@ ) where import Control.Monad.State.Strict +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal @@ -35,7 +36,7 @@ {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem. -} -encryptRSA :: Context -> ByteString -> IO ByteString +encryptRSA :: Context -> Secret -> IO ByteString encryptRSA ctx content = do publicKey <- usingHState ctx getRemotePublicKey usingState_ ctx $ do @@ -53,7 +54,7 @@ Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent -decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) +decryptRSA :: Context -> ByteString -> IO (Either KxError Secret) decryptRSA ctx econtent = do (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do @@ -69,12 +70,12 @@ generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp -generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic) -generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp +generateGroup :: Context -> Group -> IO (GroupPrivate, GroupPublicA) +generateGroup ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp -generateECDHEShared - :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) -generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub +encapsulateGroup + :: Context -> GroupPublicA -> IO (Maybe (GroupPublicB, GroupKey)) +encapsulateGroup ctx pub = usingState_ ctx $ withRNG $ groupEncapsulate pub generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp @@ -90,6 +91,9 @@ isDigitalSignatureKey (PubKeyEC _) = True isDigitalSignatureKey (PubKeyEd25519 _) = True isDigitalSignatureKey (PubKeyEd448 _) = True +isDigitalSignatureKey (PubKeyMLDSA44 _) = True +isDigitalSignatureKey (PubKeyMLDSA65 _) = True +isDigitalSignatureKey (PubKeyMLDSA87 _) = True isDigitalSignatureKey _ = False versionCompatible :: PubKey -> Version -> Bool @@ -98,6 +102,9 @@ versionCompatible (PubKeyEC _) v = v >= TLS10 versionCompatible (PubKeyEd25519 _) v = v >= TLS12 versionCompatible (PubKeyEd448 _) v = v >= TLS12 +versionCompatible (PubKeyMLDSA44 _) v = v >= TLS13 +versionCompatible (PubKeyMLDSA65 _) v = v >= TLS13 +versionCompatible (PubKeyMLDSA87 _) v = v >= TLS13 versionCompatible _ _ = False {- FOURMOLU_ENABLE -} @@ -127,6 +134,9 @@ (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k (PubKeyEd25519 _, PrivKeyEd25519 _) -> True (PubKeyEd448 _, PrivKeyEd448 _) -> True + (PubKeyMLDSA44 _, PrivKeyMLDSA44 _) -> True + (PubKeyMLDSA65 _, PrivKeyMLDSA65 _) -> True + (PubKeyMLDSA87 _, PrivKeyMLDSA87 _) -> True _ -> False getLocalPublicKey :: MonadIO m => Context -> m PubKey @@ -144,7 +154,7 @@ ---------------------------------------------------------------- class LogLabel a where - labelAndKey :: a -> (String, ByteString) + labelAndKey :: a -> (String, Secret) instance LogLabel MainSecret where labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key) @@ -164,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 () @@ -175,6 +188,7 @@ let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst) cr = unClientRandom crm (label, key) = labelAndKey logkey - debugKeyLogger (ctxDebug ctx) $ label ++ " " ++ dump cr ++ " " ++ dump key + debugKeyLogger (ctxDebug ctx) $ + label ++ " " ++ dump cr ++ " " ++ dump (convert key) where dump = init . drop 1 . showBytesHex diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -4,7 +4,10 @@ handshakeServer, handshakeServerWith, requestCertificateServer, + requestCertificateAsyncServer, keyUpdate, + sendKeyUpdate, + respondToKeyUpdate, updateKey, KeyUpdateRequest (..), ) where @@ -14,6 +17,7 @@ import Network.TLS.Context.Internal import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Server.ClientHello import Network.TLS.Handshake.Server.ClientHello12 import Network.TLS.Handshake.Server.ClientHello13 @@ -21,6 +25,7 @@ import Network.TLS.Handshake.Server.ServerHello13 import Network.TLS.Handshake.Server.TLS12 import Network.TLS.Handshake.Server.TLS13 +import Network.TLS.Imports import Network.TLS.Struct -- Put the server context in handshake mode. @@ -31,44 +36,57 @@ -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do - hss <- recvPacketHandshake ctx - case hss of - [ch] -> handshake sparams ctx ch - _ -> unexpected (show hss) (Just "client hello") + hbs <- recvPacketHandshake ctx + case hbs of + -- The keys may change after ClientHello (RFC 9846 Section 5.1) + -- and nothing else is expected anyway. + [chb] -> handshake sparams ctx chb + _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () +handshakeServerWith + :: ServerParams -> Context -> HandshakeR -> IO () handshakeServerWith = handshake -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter. --- This is useful when the client hello has been already poped from the recv layer to inspect the packet. +-- This is useful when the client hello has been already popped from the recv layer to inspect the packet. -- --- When the function returns, a new handshake has been succesfully negociated. +-- When the function returns, a new handshake has been successfully negotiated. -- On any error, a HandshakeFailed exception is raised. -handshake :: ServerParams -> Context -> Handshake -> IO () -handshake sparams ctx (ClientHello ch) = do - (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch +handshake :: ServerParams -> Context -> HandshakeR -> IO () +handshake sparams ctx chb@(ClientHello ch, bs) = do + (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs if chosenVersion == TLS13 then do - -- fixme: we should check if the client random is the same as - -- that in the first client hello in the case of hello retry. - (mClientKeyShare, r0, r1) <- + -- r0 :: Cipher, Hash, Bool + (keyShareResult, r0, r1) <- processClientHello13 sparams ctx chI - case mClientKeyShare of - Nothing -> do - sendHRR ctx r0 chI $ isJust mcrnd + case keyShareResult of + SelectKeyShareNotFound -> + throwCore $ + Error_Protocol "no group in common with the client for HRR" HandshakeFailure + SelectKeyShareHRR g -> do + sendHRR ctx g r0 chI $ isJust mcrnd -- Don't reset ctxEstablished since 0-RTT data - -- would be comming, which should be ignored. + -- would be coming, which should be ignored. handshakeServer sparams ctx - Just cliKeyShare -> do + SelectKeyShareFound cliKeyShare -> do + unless (checkClientKeyShareKeyLength cliKeyShare) $ + throwCore $ + Error_Protocol "broken key_share" IllegalParameter + -- r2 :: ( SecretTriple ApplicationSecret + -- , ClientTrafficSecret HandshakeSecret + -- , Bool -- authenticated + -- , Bool) -- rtt0OK r2 <- sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd recvClientSecondFlight13 sparams ctx r2 chI else do r <- processClientHello12 sparams ctx chI + updateTranscriptHash12 ctx chb resumeSessionData <- sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData -handshake _ _ _ = throwCore $ Error_Protocol "client Hello is expected" HandshakeFailure +handshake _ _ (hs, _) = unexpected (show hs) (Just "client hello") diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs --- a/Network/TLS/Handshake/Server/ClientHello.hs +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -29,12 +29,13 @@ :: ServerParams -> Context -> ClientHello + -> [ByteString] -> IO ( Version , ClientHello , Maybe ClientRandom -- Just for ECH to keep the outer one for key log ) -processClientHello sparams ctx ch@CH{..} = do +processClientHello sparams ctx ch@CH{..} b = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do @@ -56,7 +57,10 @@ (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes - when (chVersion /= TLS12) $ + -- A legacy_version below TLS 1.2 is refused. One above it is refused + -- only with supported_versions (RFC 9846 Section 4.1.2); without it, a + -- server negotiates TLS 1.2 (Section 4.3.1 and RFC 5246 Appendix E.1). + when (chVersion < TLS12) $ throwCore $ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion @@ -80,10 +84,17 @@ | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) | otherwise = supportedVersions $ ctxSupported ctx mVersion = debugVersionForced $ serverDebug sparams + when (clientVersions /= [] && chVersion /= TLS12) $ + throwCore $ + Error_Protocol + ("legacy_version " ++ show chVersion ++ " with supported_versions") + ProtocolVersion chosenVersion <- case mVersion of Just cver -> return cver Nothing -> - if (TLS13 `elem` serverVersions) && clientVersions /= [] + -- With supported_versions, only it is used, whether or not the + -- server supports TLS 1.3 (RFC 9846 Section 4.3.1). + if clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of Nothing -> throwCore $ @@ -127,10 +138,12 @@ else return (Nothing, False) case mClientHello' of Just chI -> do - setupI ctx chI + -- chI is created from diff. + -- encodeHandshake is a MUST. + setupI ctx chI $ [encodeHandshake $ ClientHello chI] return (chosenVersion, chI, Just chRandom) _ -> do - setupO ctx ch + setupO ctx ch b when (chosenVersion == TLS13) $ do let hasECHConf = not (null (sharedECHConfigList (serverShared sparams))) when (hasECHConf && not receivedECH) $ @@ -141,22 +154,50 @@ setECHEE True return (chosenVersion, ch, Nothing) -setupI :: Context -> ClientHello -> IO () -setupI ctx chI@CH{..} = do +setupI :: Context -> ClientHello -> [ByteString] -> IO () +setupI ctx chI@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR - unless hrr $ startHandshake ctx TLS13 chRandom - usingHState ctx $ setClientHello chI + if hrr + then checkSecondClientHello ctx chI + else startHandshake ctx TLS13 chRandom + usingHState ctx $ setClientHello chI b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName -setupO :: Context -> ClientHello -> IO () -setupO ctx ch@CH{..} = do +setupO :: Context -> ClientHello -> [ByteString] -> IO () +setupO ctx ch@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR - unless hrr $ startHandshake ctx chVersion chRandom - usingHState ctx $ setClientHello ch + if hrr + then checkSecondClientHello ctx ch + else startHandshake ctx chVersion chRandom + usingHState ctx $ setClientHello ch b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName +-- RFC 9846 Section 4.1.2: the ClientHello after HelloRetryRequest is the +-- same except for these extensions. Their order is not compared. +checkSecondClientHello :: Context -> ClientHello -> IO () +checkSecondClientHello ctx ch2 = do + mch1 <- usingHState ctx getClientHello + case mch1 of + Just (ch1, _) + | strip ch1 /= strip ch2 -> + throwCore $ + Error_Protocol "second client hello is changed" IllegalParameter + _ -> return () + where + strip ch = ch{chExtensions = sortOn eid $ filter keep $ chExtensions ch} + eid (ExtensionRaw i _) = fromExtensionID i + keep (ExtensionRaw i _) = i `notElem` mutable + mutable = + [ EID_KeyShare + , EID_EarlyData + , EID_Cookie + , EID_PreSharedKey + , EID_Padding + , EID_EncryptedClientHello + ] + -- SNI (Server Name Indication) getServerName :: [ExtensionRaw] -> Maybe HostName getServerName chExts = @@ -167,9 +208,20 @@ Nothing extractServerName where - extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns) + extractServerName (ServerName ns) = case mapMaybe toHostName ns of + [] -> Nothing + [hostName] + | all validChar hostName -> Just hostName + | otherwise -> illegal "invalid host_name in SNI" + _ -> illegal "multiple host_names in SNI" toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing + -- RFC 6066 Section 3: the server_name_list MUST NOT contain more + -- than one name of the same name_type, and HostName is an ASCII + -- DNS host name, so it has no control characters, spaces nor + -- non-ASCII bytes. + validChar c = c > ' ' && c < '\DEL' + illegal msg = E.throw $ Uncontextualized $ Error_Protocol msg IllegalParameter findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = @@ -288,8 +340,9 @@ let info = "tls ech\x00" <> encodedConfig (kdfid, aeadid) = echCipherSuite ctxR <- setupBaseR kemid kdfid aeadid skR Nothing echEnc info - let nenc = nEnc kemid - func = open ctxR + -- unreachable: setupBaseR has refused an unknown KEM + nenc <- maybe (E.throwIO $ Unsupported "KEM") return $ nEnc kemid + let func = open ctxR setTLS13HPKE ctx func nenc return $ Just (func, nenc) _ -> return Nothing 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 @@ -11,11 +11,12 @@ import Network.TLS.Crypto import Network.TLS.ErrT import Network.TLS.Extension +import Network.TLS.Handshake.Common (ticketOrSessionID12) import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature -import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters +import Network.TLS.Session (SessionManager (..)) import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types (CipherId (..), Role (..)) @@ -33,6 +34,7 @@ processClientHello12 sparams ctx ch = do let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams when secureRenegotiation $ checkSecureRenegotiation ctx ch + checkEcPointFormats ch serverName <- usingState_ ctx getClientSNI let hooks = serverHooks sparams extraCreds <- onServerNameIndication hooks serverName @@ -41,19 +43,58 @@ -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. - when (null ciphersFilteredVersion) $ + when (null ciphersFilteredVersion) $ do + checkResumedCipherOffered ctx ch throwCore $ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure - let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion + usedCipher <- chooseCipher sparams TLS12 (chCiphers ch) ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds - void $ updateTranscriptHash12 ctx $ ClientHello ch return (usedCipher, mcred) +-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer the +-- cipher suite of that session. validateSession reports its absence with +-- illegal_parameter once a cipher has been chosen; when none can be chosen, +-- the same is reported here before the missing common cipher is. +checkResumedCipherOffered :: Context -> ClientHello -> IO () +checkResumedCipherOffered ctx CH{..} = do + let mticket = + lookupAndDecode + EID_SessionTicket + MsgTClientHello + chExtensions + Nothing + (\(SessionTicket ticket) -> Just ticket) + case ticketOrSessionID12 mticket chSession of + Nothing -> return () + Just identity -> do + msd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity + case msd of + Just sd + | sessionVersion sd <= TLS12 + , CipherId (sessionCipher sd) `notElem` chCiphers -> + throwCore $ + Error_Protocol "new cipher is different from the old one" IllegalParameter + _ -> return () + checkSecureRenegotiation :: Context -> ClientHello -> IO () checkSecureRenegotiation ctx CH{..} = do -- RFC 5746: secure renegotiation -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} - when (CipherId 0xff `elem` chCiphers) $ + let hasSCSV = CipherId 0xff `elem` chCiphers + hasExt = isJust $ extensionLookup EID_SecureRenegotiation chExtensions + established <- ctxEstablished ctx + secure <- usingState_ ctx getSecureRenegotiation + -- RFC 5746 Section 3.7: when renegotiating a connection whose + -- secure_renegotiation flag is set, ClientHello MUST NOT contain + -- the SCSV and MUST contain the renegotiation_info extension. + when (established == Established && secure) $ do + when hasSCSV $ + throwCore $ + Error_Protocol "SCSV in renegotiation" HandshakeFailure + unless hasExt $ + throwCore $ + Error_Protocol "no renegotiation_info in renegotiation" HandshakeFailure + when hasSCSV $ usingState_ ctx $ setSecureRenegotiation True case extensionLookup EID_SecureRenegotiation chExtensions of @@ -103,7 +144,7 @@ -- Cipher selection is performed in two steps: first server credentials -- are flagged as not suitable for signature if not compatible with - -- negotiated signature parameters. Then ciphers are evalutated from + -- negotiated signature parameters. Then ciphers are evaluated from -- the resulting credentials. supported = serverSupported sparams @@ -131,7 +172,8 @@ -- Build a list of all hash/signature algorithms in common between -- client and server. - hashAndSignatures = supportedHashSignatures supported + -- ML-DSA is TLS 1.3 only (draft-ietf-tls-mldsa). + hashAndSignatures = filter (not . isMLDSA) $ supportedHashSignatures supported possibleHashSigAlgs = hashAndSignaturesInCommon hashAndSignatures chExtensions -- Check that a candidate signature credential will be compatible with @@ -172,6 +214,34 @@ Error_Protocol "key exchange algorithm not implemented" HandshakeFailure ---------------------------------------------------------------- + +-- RFC 8422 Section 5.1.2: a client that names a curve of RFC 8422 in +-- supported_groups and sends ec_point_formats without the uncompressed +-- format is refused with illegal_parameter. An empty list is refused +-- with decode_error when decoding it. +checkEcPointFormats :: ClientHello -> IO () +checkEcPointFormats CH{..} = + lookupAndDecodeAndDo + EID_EcPointFormats + MsgTClientHello + chExtensions + (return ()) + $ \(EcPointFormatsSupported formats) -> + when + ( EcPointFormat_Uncompressed `notElem` formats + && any (`elem` rfc8422Groups) groups + ) + $ throwCore + $ Error_Protocol "uncompressed point format missing" IllegalParameter + where + groups = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + chExtensions + [] + (\(SupportedGroups gs) -> gs) + rfc8422Groups = [P256, P384, P521, X25519, X448] negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon serverGroups exts = diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs --- a/Network/TLS/Handshake/Server/ClientHello13.hs +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -3,6 +3,7 @@ module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13, + SelectKeyShareResult (..), ) where import qualified Data.ByteString as B @@ -11,33 +12,48 @@ 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 import Network.TLS.Handshake.State import Network.TLS.IO.Encode import Network.TLS.Imports -import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types +limitSupportedGroups :: Int +limitSupportedGroups = 64 + -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context -> ClientHello -> IO - ( Maybe KeyShareEntry - , (Cipher, Hash, Bool) - , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) + ( SelectKeyShareResult + , (Cipher, Hash, Bool) -- rtt0 + , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString) + -- authenticated, is0RTTvalid, ticket ALPN ) processClientHello13 sparams ctx ch@CH{..} = do when (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions) $ throwCore $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter + -- RFC 9846 Section 9.2: the extensions a TLS 1.3 ClientHello must have. + let has eid = isJust $ extensionLookup eid chExtensions + missing reason = throwCore $ Error_Protocol reason MissingExtension + unless (has EID_PreSharedKey) $ do + unless (has EID_SignatureAlgorithms) $ + missing "no signature_algorithms extension without pre_shared_key" + unless (has EID_SupportedGroups) $ + missing "no supported_groups extension without pre_shared_key" + when (has EID_SupportedGroups /= has EID_KeyShare) $ + missing "supported_groups and key_share must come together" -- Deciding cipher. -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle @@ -45,8 +61,8 @@ when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure - let usedCipher = onCipherChoosing (serverHooks sparams) TLS13 ciphersFilteredVersion - usedHash = cipherHash usedCipher + usedCipher <- chooseCipher sparams TLS13 chCiphers ciphersFilteredVersion + let usedHash = cipherHash usedCipher rtt0 = lookupAndDecode EID_EarlyData @@ -56,9 +72,12 @@ (\(EarlyDataIndication _) -> True) if rtt0 then - -- mark a 0-RTT attempt before a possible HRR, and before updating the - -- status again if 0-RTT successful - setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding + -- Skip up to this many bytes of rejected early data: a record's worth + -- at least, even if early data is not accepted (0 by default), and + -- more only if the server accepts more. Updated if 0-RTT succeeds. + setEstablished + ctx + (EarlyDataNotAllowed (max 16384 (serverEarlyDataSize sparams))) else -- In the case of HRR, EarlyDataNotAllowed is already set. -- It should be cleared here. @@ -73,47 +92,77 @@ extract _ = require keyShares <- lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract - mshare <- findKeyShare keyShares serverGroups + let allClientGroups = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + chExtensions + [] + (\(SupportedGroups gs) -> gs) + clientGroups = take limitSupportedGroups allClientGroups + -- RFC 9846 Section 4.2.8: after HelloRetryRequest, only the selected + -- group is offered. + hrr <- usingState_ ctx getTLS13HRR + when hrr $ do + mg <- usingHState ctx getSupportedGroup + unless (map (Just . keyShareEntryGroup) keyShares == [mg]) $ + throwCore $ + Error_Protocol "key_share not for the group of hello retry" IllegalParameter + -- RFC 9846 Section 4.2.8: servers MAY check this. + unless (all ((`elem` allClientGroups) . keyShareEntryGroup) keyShares) $ + throwCore $ + Error_Protocol "key_share for a group not in supported_groups" IllegalParameter + (mgroup, doHRR) <- + onSelectKeyShare + (serverHooks sparams) + serverGroups + clientGroups + $ map keyShareEntryGroup keyShares + keyshareResult <- case mgroup of + Nothing -> return SelectKeyShareNotFound + Just g + | doHRR -> return $ SelectKeyShareHRR g + | otherwise -> case filter (\e -> keyShareEntryGroup e == g) keyShares of + [] -> return SelectKeyShareNotFound + [x] -> return $ SelectKeyShareFound x + _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter + let triple = (usedCipher, usedHash, rtt0) pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch - clientHello <- fromJust <$> usingHState ctx getClientHello - void $ updateTranscriptHash12 ctx $ ClientHello clientHello - return (mshare, triple, pskEarlySecret) + (ich, b) <- fromJust <$> usingHState ctx getClientHello + updateTranscriptHash12 ctx (ClientHello ich, b) + return (keyshareResult, triple, pskEarlySecret) where ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers = filter (cipherAllowedForVersion TLS13) (supportedCiphers $ serverSupported sparams) - serverGroups = supportedGroups (ctxSupported ctx) + serverGroups = supportedGroupsTLS13 $ serverSupported sparams -findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry) -findKeyShare ks ggs = go ggs - where - go [] = return Nothing - go (g : gs) = case filter (grpEq g) ks of - [] -> go gs - [k] -> do - unless (checkKeyShareKeyLength k) $ - throwCore $ - Error_Protocol "broken key_share" IllegalParameter - return $ Just k - _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter - grpEq g ent = g == keyShareEntryGroup ent +data SelectKeyShareResult + = -- | Negotiation failure + SelectKeyShareNotFound + | -- | Send a hello retry request with this group + SelectKeyShareHRR Group + | -- | Use this key share + SelectKeyShareFound KeyShareEntry + deriving (Eq, Show) pskAndEarlySecret :: ServerParams -> Context - -> (Cipher, Hash, Bool) + -> (Cipher, Hash, Bool) -- rtt0 -> ClientHello - -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) + -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString) + -- authenticated, is0RTTvalid, ticket ALPN pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do - (psk, binderInfo, is0RTTvalid) <- choosePSK + (psk, binderInfo, is0RTTvalid, ticketALPN) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) let earlySecret = pairBase earlyKey authenticated = isJust binderInfo preSharedKeyExt <- checkBinder earlySecret binderInfo - return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) + return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN) where choice = makeCipherChoice TLS13 usedCipher @@ -122,52 +171,72 @@ EID_PreSharedKey MsgTClientHello chExtensions - (return (zero, Nothing, False)) + (return (zero, Nothing, False, Nothing)) selectPSK - selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do + selectPSK (PreSharedKeyClientHello ids bnds) = do when (null dhModes) $ throwCore $ Error_Protocol "no psk_key_exchange_modes extension" MissingExtension if PSK_DHE_KE `elem` dhModes then do let len = sum (map (\x -> B.length x + 1) bnds) + 2 - mgr = sharedSessionManager $ serverShared sparams - -- sessionInvalidate is not used for TLS 1.3 - -- because PSK is always changed. - -- So, identity is not stored in Context. - msdata <- - if rtt0 - then sessionResumeOnlyOnce mgr identity - else sessionResume mgr identity - case msdata of - Just sdata -> do - let tinfo = fromJust $ sessionTicketInfo sdata - psk = sessionSecret sdata - isFresh <- checkFreshness tinfo obfAge - (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata - if isPSKvalid && isFresh - then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid) - else -- fall back to full handshake - return (zero, Nothing, False) - _ -> return (zero, Nothing, False) - else return (zero, Nothing, False) - selectPSK _ = return (zero, Nothing, False) + -- The first identity that can be resumed is chosen, each + -- with its own age and binder. + tryPSK len $ zip3 [0 ..] ids bnds + else return (zero, Nothing, False, Nothing) + selectPSK _ = return (zero, Nothing, False, Nothing) + tryPSK _ [] = return (zero, Nothing, False, Nothing) + tryPSK len ((n, PskIdentity identity obfAge, bnd) : rest) = do + let mgr = sharedSessionManager $ serverShared sparams + -- sessionInvalidate is not used for TLS 1.3 + -- because PSK is always changed. + -- So, identity is not stored in Context. + -- Early data is only with the first identity. + msdata <- + if rtt0 && n == 0 + then sessionResumeOnlyOnce mgr identity + else sessionResume mgr identity + case msdata of + -- RFC 8446 Section 4.6.1: only a TLS 1.3 session, which + -- has its ticket information, is resumed with a PSK. A + -- TLS 1.2 one found under the same identity falls back + -- to a full handshake. + Just sdata + | sessionVersion sdata == TLS13 + , Just tinfo <- sessionTicketInfo sdata -> do + let psk = sessionSecret sdata + isFresh <- checkFreshness tinfo obfAge + (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata + if isPSKvalid && isFresh + then do + restoreClientCertificate ctx sdata + -- The application is asked only when 0-RTT is + -- otherwise possible. + accepted <- + if rtt0 && is0RTTvalid && n == 0 + then onAccept0RTT (serverHooks sparams) sdata + else return False + return + ( psk + , Just (bnd, n :: Int, len) + , accepted + , sessionALPN sdata + ) + else tryPSK len rest + _ -> tryPSK len rest + checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder, n, tlen)) = do - ch <- fromJust <$> usingHState ctx getClientHello - let ech = encodeHandshake $ ClientHello ch - binder' = makePSKBinder earlySecret usedHash tlen ech + (_, b) <- fromJust <$> usingHState ctx getClientHello + binder' <- makePSKBinder ctx earlySecret usedHash tlen $ B.concat b unless (binder == binder') $ decryptError "PSK binder validation failed" return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n] checkSessionEquality sdata = do msni <- usingState_ ctx getClientSNI - -- ALPN should be checked. - -- But it's an extension in EE, sigh. - -- malpn <- usingState_ ctx getNegotiatedProtocol let isSameSNI = sessionClientSNI sdata == msni isSameCipher = sessionCipher sdata == cipherID usedCipher ciphers = supportedCiphers $ serverSupported sparams @@ -176,9 +245,10 @@ Nothing -> False Just c -> cipherHash c == cipherHash usedCipher isSameVersion = TLS13 == sessionVersion sdata - -- isSameALPN = sessionALPN sdata == malpn - isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required - is0RTTvalid = isSameVersion && isSameCipher -- && isSameALPN + -- RFC 9846 does not require the same SNI, but a session of + -- another name may have other credentials and settings. + isPSKvalid = isSameKDF && isSameSNI + is0RTTvalid = isSameVersion && isSameCipher return (isPSKvalid, is0RTTvalid) dhModes = 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 @@ -2,6 +2,7 @@ module Network.TLS.Handshake.Server.Common ( applicationProtocol, + chooseCipher, checkValidClientCertChain, clientCertificate, credentialDigitalSignatureKey, @@ -17,6 +18,7 @@ import Control.Monad.State.Strict import Data.X509 (ExtKeyUsageFlag (..)) +import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Credentials import Network.TLS.Crypto @@ -29,9 +31,29 @@ 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 +-- | 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 -> + throwCore $ + Error_Protocol + "onCipherChoosing selected a cipher outside the candidate list" + InternalError + where + 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 checkValidClientCertChain ctx errmsg = do @@ -132,6 +154,11 @@ when (proto == "") $ throwCore $ Error_Protocol "no supported application protocols" NoApplicationProtocol + unless (proto `elem` protos) $ + throwCore $ + Error_Protocol + "ALPN callback selected a protocol not offered by the client" + NoApplicationProtocol usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto @@ -151,8 +178,13 @@ (onClientCertificate (serverHooks sparams) certs) rejectOnException case usage of - CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs - CertificateUsageReject reason -> certificateRejected reason + CertificateUsageAccept -> do + verifyLeafKeyUsage [KeyUsage_digitalSignature] certs + verifyLeafKeyUsagePurpose + (supportedClientCertificatePurposes $ serverSupported sparams) + certs + verifyLeafKeySize (serverSupported sparams) certs + CertificateUsageReject reason -> certificateRejected ctx [] certs reason -- Remember cert chain for later use. -- @@ -165,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 @@ -202,4 +234,10 @@ let mysiz = fromIntegral mylim + if tls13 then 1 else 0 rsl = RecordSizeLimit mysiz return $ Just $ toExtensionRaw rsl - else return Nothing + else do + -- RFC 8449 Section 4: a limit that is not negotiated + -- does not bind the peer, so a client that did not send + -- RecordSizeLimit may send records of any size the + -- protocol permits. + setMyRecordLimit ctx Nothing + return Nothing diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs --- a/Network/TLS/Handshake/Server/ServerHello12.hs +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -5,6 +5,8 @@ sendServerHello12, ) where +import Data.ByteArray (convert) + import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal @@ -42,16 +44,17 @@ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions let ff = ServerHello sh : build [ServerHelloDone] - sendPacket12 ctx $ Handshake ff + sendPacket12 ctx $ Handshake ff [] contextFlush ctx Just sessionData -> do usingState_ ctx $ do setSession chSession setTLS12SessionResuming True + restoreClientCertificate ctx sessionData sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession - sendPacket12 ctx $ Handshake [ServerHello sh] - let mainSecret = sessionSecret sessionData + sendPacket12 ctx $ Handshake [ServerHello sh] [] + let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole @@ -91,7 +94,7 @@ | TLS12 < sessionVersion sd = return Nothing -- fixme | CipherId (sessionCipher sd) `notElem` ciphers = throwCore $ - Error_Protocol "new cipher is diffrent from the old one" IllegalParameter + Error_Protocol "new cipher is different from the old one" IllegalParameter | isJust sni && sessionClientSNI sd /= sni = do usingState_ ctx clearClientSNI return Nothing @@ -140,8 +143,8 @@ if serverWantClientCert then do let (certTypes, hashSigs) = - let as = supportedHashSignatures serverSupported - in (nub $ mapMaybe hashSigToCertType as, as) + let as = filter (not . isMLDSA) $ supportedHashSignatures serverSupported + in (nub $ mapMaybe (fmap certTypeOnWire . hashSigToCertType) as, as) creq = CertRequest certTypes @@ -151,8 +154,18 @@ return $ b2 . (creq :) else return b2 where + -- RFC 8422 Section 3.1: in TLS 1.2, ecdsa_sign asks for a certificate + -- with an ECDSA- or EdDSA-capable public key. The Ed25519 and Ed448 + -- certificate types are synthetic values with no code point. + certTypeOnWire CertificateType_Ed25519_Sign = CertificateType_ECDSA_Sign + certTypeOnWire CertificateType_Ed448_Sign = CertificateType_ECDSA_Sign + certTypeOnWire t = t commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts - commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts + -- ML-DSA is TLS 1.3 only (draft-ietf-tls-mldsa). + commonHashSigs = + hashAndSignaturesInCommon + (filter (not . isMLDSA) $ supportedHashSignatures serverSupported) + chExts setup_DHE = do let possibleFFGroups = commonGroups `intersect` availableFFGroups (dhparams, priv, pub) <- @@ -184,7 +197,11 @@ -- not called. decideHashSig pubKey = do case filter (pubKey `signatureCompatible`) commonHashSigs of - [] -> error ("no hash signature for " ++ pubkeyType pubKey) + [] -> + throwCore $ + Error_Protocol + ("no hash signature for " ++ pubkeyType pubKey) + HandshakeFailure x : _ -> return x generateSKX_DHE kxsAlg = do @@ -202,10 +219,10 @@ setup_ECDHE grp = do usingHState ctx $ setSupportedGroup grp - (srvpri, srvpub) <- generateECDHE ctx grp + (srvpri, srvpub) <- generateGroup ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams - usingHState ctx $ setGroupPrivate srvpri + usingHState ctx $ setGroupPrivate [(grp, srvpri)] return serverParams generateSKX_ECDHE kxsAlg = do @@ -265,9 +282,13 @@ | ems = Just $ toExtensionRaw ExtendedMainSecret | otherwise = Nothing + -- RFC 5077 Section 3.2: the extension is sent only to a client that + -- sent it. let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams + clientTicket = isJust $ extensionLookup EID_SessionTicket chExts sessionTicketExt - | not resuming && useTicket = Just $ toExtensionRaw $ SessionTicket "" + | not resuming && useTicket && clientTicket = + Just $ toExtensionRaw $ SessionTicket "" | otherwise = Nothing -- in TLS12, we need to check as well the certificates we are sending if they have in the extension diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -36,17 +36,18 @@ :: ServerParams -> Context -> KeyShareEntry - -> (Cipher, Hash, Bool) - -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) + -> (Cipher, Hash, Bool) -- rtt0 + -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString) + -- authenticated, is0RTTvalid, ticket ALPN -> ClientHello -> Maybe ClientRandom -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret - , Bool - , Bool + , Bool -- authenticated + , Bool -- rtt0OK ) -sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do +sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN) CH{..} mOuterClientRandom = do let clientEarlySecret = pairClient earlyKey earlySecret = pairBase earlyKey -- parse CompressCertificate to check if it is broken here @@ -69,8 +70,15 @@ setOuterClientRandom mOuterClientRandom hrr <- usingState_ ctx getTLS13HRR alpnExt <- applicationProtocol ctx chExtensions sparams + negotiatedALPN <- usingState_ ctx getNegotiatedProtocol setServerParameter - let rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid + let rtt0OK = + authenticated + && not hrr + && rtt0 + && rtt0accept + && is0RTTvalid + && ticketALPN == negotiatedALPN extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) let p = makeCredentialPredicate TLS13 chExtensions @@ -86,7 +94,7 @@ usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted else do - usingHState ctx $ setTLS13HandshakeMode PreSharedKey + when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey usingHState ctx $ setTLS13RTT0Status RTT0Rejected else when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey -- else : FullHandshake or HelloRetryRequest @@ -120,7 +128,7 @@ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs - loadPacket13 ctx $ Handshake13 [rawFinished] + loadPacket13 ctx $ Handshake13 [rawFinished] [] return (clientHandshakeSecret, handSecret) ---------------------------------------------------------------- hChSf <- transcriptHash ctx "CH..SF" @@ -152,8 +160,11 @@ rtt0accept = serverEarlyDataSize sparams > 0 decideCredentialInfo allCreds = do + -- RFC 9846 Section 4.2.3: also with pre_shared_key, which falls + -- back to a certificate here. let err = - throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError + throwCore $ + Error_Protocol "no signature_algorithms extension" MissingExtension cHashSigs <- lookupAndDecodeAndDo EID_SignatureAlgorithms @@ -204,7 +215,7 @@ , shExtensions = shExts } usingHState ctx $ setECHAccepted True - loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] + loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] [] else do srand <- liftIO $ @@ -220,26 +231,26 @@ , shComp = 0 , shExtensions = shExts } - loadPacket13 ctx $ Handshake13 [ServerHello13 sh] + loadPacket13 ctx $ Handshake13 [ServerHello13 sh] [] sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here. certReq = makeCertRequest sparams ctx certReqCtx True - loadPacket13 ctx $ Handshake13 [certReq] + loadPacket13 ctx $ Handshake13 [certReq] [] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) [] let certtag = if zlib then CompressedCertificate13 else Certificate13 loadPacket13 ctx $ - Handshake13 [certtag "" (CertificateChain_ certChain) ess] + Handshake13 [certtag "" (CertificateChain_ certChain) ess] [] liftIO $ usingState_ ctx $ setServerCertificateChain certChain hChSc <- transcriptHash ctx "CH..SC" pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc - loadPacket13 ctx $ Handshake13 [vrfy] + loadPacket13 ctx $ Handshake13 [vrfy] [] sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do msni <- liftIO $ usingState_ ctx getClientSNI @@ -285,12 +296,12 @@ ] eeExtensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions - loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] + loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13 - :: [HashAndSignatureAlgorithm] + :: [SignatureScheme] -> Credentials - -> Maybe (Credential, HashAndSignatureAlgorithm) + -> Maybe (Credential, SignatureScheme) credentialsFindForSigning13 hss0 creds = loop hss0 where loop [] = Nothing @@ -300,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 @@ -313,34 +324,22 @@ ---------------------------------------------------------------- -sendHRR :: Context -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO () -sendHRR ctx (usedCipher, usedHash, _) CH{..} isEch = do +sendHRR :: Context -> Group -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO () +sendHRR ctx g (usedCipher, usedHash, _) CH{..} isEch = do twice <- usingState_ ctx getTLS13HRR when twice $ throwCore $ Error_Protocol "Hello retry not allowed again" HandshakeFailure usingState_ ctx $ setTLS13HRR True failOnEitherError $ setServerHelloParameters13 ctx usedCipher True - let clientGroups = - lookupAndDecode - EID_SupportedGroups - MsgTClientHello - chExtensions - [] - (\(SupportedGroups gs) -> gs) - possibleGroups = serverGroups `intersect` clientGroups - case possibleGroups of - [] -> - throwCore $ - Error_Protocol "no group in common with the client for HRR" HandshakeFailure - g : _ -> do - hrr <- makeHRR ctx usedCipher usedHash chSession g isEch - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest - runPacketFlight ctx $ do - loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] - sendChangeCipherSpec13 ctx - where - serverGroups = supportedGroups (ctxSupported ctx) + hrr <- makeHRR ctx usedCipher usedHash chSession g isEch + usingHState ctx $ do + setTLS13HandshakeMode HelloRetryRequest + -- Checked against the key_share of the second ClientHello. + setSupportedGroup g + runPacketFlight ctx $ do + loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] [] + sendChangeCipherSpec13 ctx makeHRR :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs --- a/Network/TLS/Handshake/Server/TLS12.hs +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -5,10 +5,12 @@ ) where import Control.Monad.State.Strict (gets) +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Crypto +import Network.TLS.Extension import Network.TLS.Handshake.Common import Network.TLS.Handshake.Key import Network.TLS.Handshake.Server.Common @@ -36,11 +38,17 @@ Nothing -> do recvClientCCC sparams ctx mticket <- sessionEstablished ctx + -- RFC 5077 Section 3.3: NewSessionTicket is sent only after + -- the session_ticket extension in ServerHello, which only a + -- client that sent it gets. + clientTicket <- + maybe False (isJust . extensionLookup EID_SessionTicket . chExtensions . fst) + <$> usingHState ctx getClientHello case mticket of - Nothing -> return () - Just ticket -> do + Just ticket | clientTicket -> do let life = adjustLifetime $ serverTicketLifetime sparams - sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] + sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] [] + _ -> return () sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx @@ -91,8 +99,17 @@ -- matches our request and that we support -- verifying with that certificate. - return $ RecvStateHandshake $ expectClientKeyExchange True - expectClientCertificate p = expectClientKeyExchange False p + -- RFC 5246 Section 7.4.8: CertificateVerify follows only a + -- certificate with signing capability, so not an empty one, + -- which the hook may have accepted. + let followedCertVerify = not $ isNullCertificateChain certs + return $ RecvStateHandshake $ expectClientKeyExchange followedCertVerify + -- RFC 5246 Section 7.4.6: a client asked for a certificate sends the + -- message, empty if it has none. + expectClientCertificate p = do + certReqSent <- usingHState ctx getCertReqSent + when certReqSent $ unexpected (show p) (Just "client certificate") + expectClientKeyExchange False p -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher, -- so we must process any packet, and in case of handshake call processHandshake manually. @@ -142,10 +159,11 @@ -- BadRecordMac is nonsense but for tlsfuzzer throwCore $ Error_Protocol "invalid client public key" BadRecordMac - Right preMain -> case decodePreMainSecret preMain of - Left _ -> usingHState ctx $ setMainSecretFromPre rver role random + Right preMain -> case decodePreMainSecret $ convert preMain of + Left _ -> usingHState ctx $ setMainSecretFromPre rver role $ convert random Right (ver, _) - | ver /= expectedVer -> usingHState ctx $ setMainSecretFromPre rver role random + | ver /= expectedVer -> + usingHState ctx $ setMainSecretFromPre rver role $ convert random | otherwise -> usingHState ctx $ setMainSecretFromPre rver role preMain logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do @@ -164,21 +182,23 @@ logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams - case decodeGroupPublic grp bytes of + case groupDecodePublicB grp bytes of Left _ -> throwCore $ Error_Protocol "client public key cannot be decoded" IllegalParameter Right clipub -> do - srvpri <- usingHState ctx getGroupPrivate - case groupGetShared clipub srvpri of - Just preMain -> do - rver <- usingState_ ctx getVersion - role <- usingState_ ctx getRole - mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain - logKey ctx (MainSecret mainSecret) - Nothing -> - throwCore $ - Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter + grpSpris <- usingHState ctx getGroupPrivate + case lookup grp grpSpris of + Nothing -> throwCore err + Just srvpri -> case groupDecapsulate clipub srvpri of + Just preMain -> do + rver <- usingState_ ctx getVersion + role <- usingState_ ctx getRole + mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain + logKey ctx (MainSecret mainSecret) + Nothing -> throwCore err + where + err = Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs --- a/Network/TLS/Handshake/Server/TLS13.hs +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -1,17 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Handshake.Server.TLS13 ( recvClientSecondFlight13, requestCertificateServer, + requestCertificateAsyncServer, keyUpdate, + sendKeyUpdate, + respondToKeyUpdate, updateKey, KeyUpdateRequest (..), ) where -import Control.Exception +import Control.Concurrent.MVar +import qualified Control.Exception as E import Control.Monad.State.Strict -import qualified Data.ByteString.Char8 as C8 import Data.IORef import Network.TLS.Cipher @@ -29,6 +33,7 @@ import Network.TLS.IO import Network.TLS.Imports import Network.TLS.KeySchedule +import Network.TLS.Packet13 (encodeHandshake13) import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State @@ -71,7 +76,7 @@ then setPendingRecvActions ctx - [ PendingRecvAction True True $ expectEndOfEarlyData ctx clientHandshakeSecret + [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret , PendingRecvActionHash True $ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime ] @@ -104,7 +109,10 @@ expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13") expectEndOfEarlyData - :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO () + :: Context + -> ClientTrafficSecret HandshakeSecret + -> Handshake13 + -> IO () expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do (usedHash, usedCipher, _, _) <- getRxRecordState ctx setRxRecordState ctx usedHash usedCipher clientHandshakeSecret @@ -145,7 +153,7 @@ psk = derivePSK choice resumptionSecret nonce (identity, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce identity rtt0max - sendPacket13 ctx $ Handshake13 [nst] + sendPacket13 ctx $ Handshake13 [nst] [] where choice = makeCipherChoice TLS13 usedCipher rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams @@ -179,8 +187,18 @@ | otherwise = fromIntegral i expectCertVerify - :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () -expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do + :: MonadIO m + => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () +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 @@ -190,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" ---------------------------------------------------------------- @@ -227,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 @@ -236,27 +242,96 @@ origCertReqCtx <- newCertReqContext ctx let certReq13 = makeCertRequest sparams ctx origCertReqCtx False _ <- withWriteLock ctx $ do - bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do - sendPacket13 ctx $ Handshake13 [certReq13] + E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do + sendPacket13 ctx $ Handshake13 [certReq13] [] withReadLock ctx $ do - clientCert13 <- getHandshake ctx ref - emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13 baseHState <- saveHState ctx - void $ updateTranscriptHash13 ctx certReq13 - void $ updateTranscriptHash13 ctx clientCert13 + -- RFC 8446 Section 4.4: the handshake context of + -- post-handshake authentication is ClientHello ... client + -- Finished + CertificateRequest. + updateTranscriptHash13 ctx (certReq13, [encodeHandshake13 certReq13]) + (clientCert13, bClientCert13) <- getHandshake ctx ref + emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13 + updateTranscriptHash13 ctx (clientCert13, bClientCert13) th <- transcriptHash ctx "CH..Cert" - unless emptyCert $ do - certVerify13 <- getHandshake ctx ref - expectCertVerify sparams ctx th certVerify13 - void $ updateTranscriptHash13 ctx certVerify13 - finished13 <- getHandshake ctx ref - expectClientFinished ctx finished13 + 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 + 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 :: Context -> IORef [Handshake13] -> IO Handshake13 +getHandshake + :: Context -> IORef [Handshake13R] -> IO Handshake13R getHandshake ctx ref = do hhs <- readIORef ref if null hhs @@ -265,23 +340,36 @@ either (terminate ctx) process ex else chk hhs where - process (Handshake13 iss) = chk iss + process (Handshake13 hss bss) = chk $ zip hss bss process _ = terminate ctx $ Error_Protocol "post handshake authenticated" UnexpectedMessage chk [] = getHandshake ctx ref - chk (KeyUpdate13 mode : hs) = do + chk ((KeyUpdate13 mode, _) : hbs) = do + complete <- isRecvComplete ctx + unless (complete && null hbs) $ + terminate ctx $ + Error_Protocol + "received message not aligned with record boundary" + UnexpectedMessage + case limitKeyUpdate $ sharedLimit $ ctxShared ctx of + Just limit | limit > 0 -> do + count <- incrementTLS13KeyUpdateCount ctx + when (count > limit) $ + terminate ctx $ + Error_Protocol "too many consecutive KeyUpdate messages" UnexpectedMessage + _ -> return () keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. - when (mode == UpdateRequested) $ withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] - keyUpdate ctx getTxRecordState setTxRecordState - chk hs - chk (h : hs) = do - writeIORef ref hs - return h + when (mode == UpdateRequested) $ + withWriteLock ctx $ + respondToKeyUpdate ctx + chk hbs + chk (hb : hbs) = do + writeIORef ref hbs + return hb expectClientCertificate :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool @@ -306,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 @@ -325,25 +412,25 @@ send = sendPacket13 ctx . Alert13 catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx - throwIO $ Terminated False reason err + E.throwIO $ Terminated False reason err handleEx :: Context -> IO Bool -> IO Bool handleEx ctx f = catchException f $ \exception -> do -- If the error was an Uncontextualized TLSException, we replace the -- context with HandshakeFailed. If it's anything else, we convert -- it to a string and wrap it with Error_Misc and HandshakeFailed. - let tlserror = case fromException exception of + let tlserror = case E.fromException exception of Just e | Uncontextualized e' <- e -> e' _ -> Error_Misc (show exception) sendPacket13 ctx $ Alert13 [errorToAlert tlserror] - void $ throwIO $ PostHandshake tlserror + void $ E.throwIO $ PostHandshake tlserror return False ---------------------------------------------------------------- keyUpdate :: Context - -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString)) + -> (Context -> IO (Hash, Cipher, CryptLevel, Secret)) -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()) -> IO () keyUpdate ctx getState setState = do @@ -358,6 +445,32 @@ hashDigestSize usedHash setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1) +-- | Sending a KeyUpdate and switching to the next Tx keys, with the write +-- lock held. Nothing is sent and 'False' is returned if the epoch would +-- exceed 2^48-1 (RFC 9846 Section 4.7.3). +sendKeyUpdate :: Context -> KeyUpdate -> IO Bool +sendKeyUpdate ctx req = do + sent <- tls13stSentKeyUpdates <$> getTLS13State ctx + if sent >= 2 ^ (48 :: Int) - 1 + then return False + else do + sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] [] + keyUpdate ctx getTxRecordState setTxRecordState + modifyTLS13State ctx $ \st -> st{tls13stSentKeyUpdates = sent + 1} + return True + +-- | Answers a KeyUpdate with update_requested. RFC 9846 Section 4.6.3: +-- several received while we send no application data get one answer. The +-- request is ignored after 2^48-1 updates. +respondToKeyUpdate :: Context -> IO () +respondToKeyUpdate ctx = do + responded <- tls13stKeyUpdateResponded <$> getTLS13State ctx + unless responded $ do + sent <- sendKeyUpdate ctx UpdateNotRequested + when sent $ + modifyTLS13State ctx $ + \st -> st{tls13stKeyUpdateResponded = True} + -- | How to update keys in TLS 1.3 data KeyUpdateRequest = -- | Unidirectional key update @@ -366,19 +479,19 @@ TwoWay deriving (Eq, Show) --- | Updating appication traffic secrets for TLS 1.3. --- If this API is called for TLS 1.3, 'True' is returned. --- Otherwise, 'False' is returned. +-- | Updating application traffic secrets for TLS 1.3. +-- 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 @@ -44,35 +45,91 @@ certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes certificateCompatible (PubKeyEd25519 _) _ = True certificateCompatible (PubKeyEd448 _) _ = True +-- ML-DSA has no CertificateType of its own, as EdDSA does not either; what +-- a client may send is decided by signature_algorithms. +certificateCompatible (PubKeyMLDSA44 _) _ = True +certificateCompatible (PubKeyMLDSA65 _) _ = True +certificateCompatible (PubKeyMLDSA87 _) _ = True certificateCompatible _ _ = False -signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool -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 -signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256 -signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384 -signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512 -signatureCompatible (PubKeyDSA _) (_, SignatureDSA) = True -signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True -signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True -signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True -signatureCompatible _ (_, _) = False +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 +-- for as though it were RSASSA-PSS. +signatureCompatible (PubKeyMLDSA44 _) MLDSA44 = True +signatureCompatible (PubKeyMLDSA65 _) MLDSA65 = True +signatureCompatible (PubKeyMLDSA87 _) MLDSA87 = True +signatureCompatible _ MLDSA44 = False +signatureCompatible _ MLDSA65 = False +signatureCompatible _ MLDSA87 = False +signatureCompatible (PubKeyRSA pk) 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) 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. +-- +-- This takes the whole scheme and not its second byte alone, because +-- ML-DSA's second byte is one RSASSA-PSS also uses: only the pair says +-- which of the two a scheme is. The ML-DSA equations come first for the +-- same reason -- an ML-DSA scheme fits no other kind of key, and one +-- ML-DSA size does not fit another's key. +keyTypeFits :: PubKey -> 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 _) 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 -> SignatureScheme -> IO () +checkKeyTypeFits pubKey hs = + unless (pubKey `keyTypeFits` hs) $ + throwCore $ + Error_Protocol + ("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'. @@ -90,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 @@ -118,9 +174,24 @@ -> ByteString -> DigitallySigned -> IO Bool -checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) - | pubKey `signatureCompatible` hashSigAlg = doVerify - | otherwise = return False +-- An algorithm not offered in CertificateRequest (RFC 5246 Section +-- 7.4.8), or one for another type of key, is a field that is incorrect, +-- an illegal_parameter. One for the right type of key that still does +-- not fit it, an RSASSA-PSS one for an rsaEncryption key say, is a +-- signature that does not verify, a decrypt_error, which False leads to. +checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) = do + -- ML-DSA is defined for TLS 1.3 only, so naming one here is a field + -- that is incorrect whatever key the peer holds. + when (usedVersion < TLS13 && isMLDSA hashSigAlg) $ + throwCore $ + Error_Protocol + ("signature algorithm " ++ show hashSigAlg ++ " is not for " ++ show usedVersion) + IllegalParameter + checkSupportedHashSignature ctx hashSigAlg + checkKeyTypeFits pubKey hashSigAlg + if pubKey `signatureCompatible` hashSigAlg + then doVerify + else return False where doVerify = prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs @@ -130,7 +201,7 @@ :: Context -> Version -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> ByteString -> IO DigitallySigned createCertificateVerify ctx usedVersion pubKey hashSigAlg msgs = @@ -149,77 +220,90 @@ :: 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 signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") 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 +-- Checked as checkCertificateVerify does: the peer chose the algorithm, so +-- one that does not fit the key is its error, not ours. signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = do usedVersion <- usingState_ ctx getVersion - let (sigParam, toVerify) = - case (usedVersion, hashSigAlg) of - (TLS12, hs) - | pubKey `signatureCompatible` hs -> - (signatureParams pubKey hashSigAlg, toVerifyData) - | otherwise -> - error "expecting different signature algorithm" - _ -> - error - "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" - signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) + unless (usedVersion == TLS12) $ + throwCore $ + Error_Protocol + ("no signature algorithm in a " ++ show usedVersion ++ " digitally-signed") + InternalError + checkSupportedHashSignature ctx hashSigAlg + checkKeyTypeFits pubKey hashSigAlg + if pubKey `signatureCompatible` hashSigAlg + then + signatureVerifyWithCertVerifyData + ctx + digSig + (signatureParams pubKey hashSigAlg, toVerifyData) + else return False signatureVerifyWithCertVerifyData :: Context @@ -228,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 @@ -247,7 +335,7 @@ :: Context -> ServerDHParams -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> IO DigitallySigned digitallySignDHParams ctx serverParams pubKey mhash = do dhParamsData <- @@ -258,7 +346,7 @@ :: Context -> ServerECDHParams -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> IO DigitallySigned digitallySignECDHParams ctx serverParams pubKey mhash = do ecdhParamsData <- @@ -298,7 +386,7 @@ -- 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: " ++ show hs 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 @@ -68,8 +69,8 @@ getTLS13HandshakeMode, setTLS13RTT0Status, getTLS13RTT0Status, - setTLS13EarlySecret, - getTLS13EarlySecret, + setTLS13EarlySecrets, + getTLS13EarlySecrets, setTLS13ResumptionSecret, getTLS13ResumptionSecret, setTLS13CertComp, @@ -81,7 +82,7 @@ ) where import Control.Monad.State.Strict -import Data.ByteArray (ByteArrayAccess) +import Data.ByteArray (convert) import Data.X509 (CertificateChain) import Network.TLS.Cipher @@ -104,7 +105,7 @@ = -- | Initial state TransHashState0 | -- | A raw CH is stored since hash algo is not chosen yet. - TransHashState1 ByteString + TransHashState1 [ByteString] | -- | Hashed TransHashState2 HashCtx @@ -120,12 +121,12 @@ , hstClientRandom :: ClientRandom -- ^ For ECH, inner client random. , hstServerRandom :: Maybe ServerRandom - , hstMainSecret :: Maybe ByteString + , hstMainSecret :: Maybe Secret , hstKeyState :: HandshakeKeyState , hstServerDHParams :: Maybe ServerDHParams , hstDHPrivate :: Maybe DHPrivate , hstServerECDHParams :: Maybe ServerECDHParams - , hstGroupPrivate :: Maybe GroupPrivate + , hstGroupPrivate :: [(Group, GroupPrivate)] , hstTransHashState :: TransHashState , hstTransHashStateI :: TransHashState -- Inner CH for client ECH , hstHandshakeMessages :: [ByteString] @@ -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,20 +149,26 @@ , 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 , hstPendingCompression :: Compression , hstExtendedMainSecret :: Bool , hstSupportedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: RTT0Status - , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx + , hstTLS13EarlySecrets :: [BaseSecret EarlySecret] + -- ^ Client: one for each PSK offered , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool , hstCCS13Recv :: Bool , hstTLS13OuterClientRandom :: Maybe ClientRandom -- ^ Used for key logging in the case of ECH. - , hstTLS13ClientHello :: Maybe ClientHello + , hstTLS13ClientHello :: Maybe (ClientHello, [ByteString]) -- ^ Inner client hello in the case of ECH. , hstTLS13ECHAccepted :: Bool , hstTLS13ECHEE :: Bool @@ -212,7 +219,7 @@ -- present Ed25519 and Ed448 certificates when these become supported. type CertReqCBdata = ( [CertificateType] - , Maybe [HashAndSignatureAlgorithm] + , Maybe [SignatureScheme] , [DistinguishedName] ) @@ -236,7 +243,7 @@ , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing - , hstGroupPrivate = Nothing + , hstGroupPrivate = [] , hstTransHashState = TransHashState0 , hstTransHashStateI = TransHashState0 , hstHandshakeMessages = [] @@ -248,13 +255,16 @@ , hstClientCertChain = Nothing , hstPendingTxState = Nothing , hstPendingRxState = Nothing + , hstServerSignatureScheme = Nothing + , hstClientSignatureScheme = Nothing + , hstRxSwitched = False , hstPendingCipher = Nothing , hstPendingCompression = nullCompression , hstExtendedMainSecret = False , hstSupportedGroup = Nothing , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None - , hstTLS13EarlySecret = Nothing + , hstTLS13EarlySecrets = [] , hstTLS13ResumptionSecret = Nothing , hstTLS13CertComp = False , hstCCS13Sent = False @@ -303,11 +313,11 @@ getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate -getGroupPrivate :: HandshakeM GroupPrivate -getGroupPrivate = fromJust <$> gets hstGroupPrivate +getGroupPrivate :: HandshakeM [(Group, GroupPrivate)] +getGroupPrivate = gets hstGroupPrivate -setGroupPrivate :: GroupPrivate -> HandshakeM () -setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = Just shp}) +setGroupPrivate :: [(Group, GroupPrivate)] -> HandshakeM () +setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = shp}) setExtendedMainSecret :: Bool -> HandshakeM () setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b}) @@ -352,11 +362,11 @@ getTLS13RTT0Status :: HandshakeM RTT0Status getTLS13RTT0Status = gets hstTLS13RTT0Status -setTLS13EarlySecret :: BaseSecret EarlySecret -> HandshakeM () -setTLS13EarlySecret secret = modify' (\hst -> hst{hstTLS13EarlySecret = Just secret}) +setTLS13EarlySecrets :: [BaseSecret EarlySecret] -> HandshakeM () +setTLS13EarlySecrets secrets = modify' (\hst -> hst{hstTLS13EarlySecrets = secrets}) -getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) -getTLS13EarlySecret = gets hstTLS13EarlySecret +getTLS13EarlySecrets :: HandshakeM [BaseSecret EarlySecret] +getTLS13EarlySecrets = gets hstTLS13EarlySecrets setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM () setTLS13ResumptionSecret secret = modify' (\hst -> hst{hstTLS13ResumptionSecret = Just secret}) @@ -403,11 +413,11 @@ setOuterClientRandom :: Maybe ClientRandom -> HandshakeM () setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr}) -getClientHello :: HandshakeM (Maybe ClientHello) +getClientHello :: HandshakeM (Maybe (ClientHello, [ByteString])) getClientHello = gets hstTLS13ClientHello -setClientHello :: ClientHello -> HandshakeM () -setClientHello ch = modify' $ \hst -> hst{hstTLS13ClientHello = Just ch} +setClientHello :: ClientHello -> [ByteString] -> HandshakeM () +setClientHello ch b = modify' $ \hst -> hst{hstTLS13ClientHello = Just (ch, b)} getECHAccepted :: HandshakeM Bool getECHAccepted = gets hstTLS13ECHAccepted @@ -444,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 -- @@ -463,14 +478,13 @@ -- | Generate the main secret from the pre-main secret. setMainSecretFromPre - :: ByteArrayAccess preMain - => Version + :: Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side - -> preMain + -> Secret -- ^ the pre-main secret - -> HandshakeM ByteString + -> HandshakeM Secret setMainSecretFromPre ver role preMainSecret = do ems <- getExtendedMainSecret secret <- if ems then get >>= genExtendedSecret else genSecret <$> get @@ -499,7 +513,7 @@ -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. -setMainSecret :: Version -> Role -> ByteString -> HandshakeM () +setMainSecret :: Version -> Role -> Secret -> HandshakeM () setMainSecret ver role mainSecret = modify' $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role in hst @@ -509,7 +523,7 @@ } computeKeyBlock - :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) + :: HandshakeState -> Secret -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust $ hstPendingCipher hst @@ -538,13 +552,13 @@ cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey - , cstIV = cWriteIV + , cstIV = convert $ cWriteIV , cstMacSecret = cMACSecret } cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey - , cstIV = sWriteIV + , cstIV = convert $ sWriteIV , cstMacSecret = sMACSecret } msClient = MacState{msSequence = 0} diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -13,10 +13,12 @@ setRxRecordState, getTxLevel, getRxLevel, + getTxSequence, clearTxRecordState, clearRxRecordState, PendingRecvAction (..), setPendingRecvActions, + pushPendingRecvAction, popPendingRecvAction, ) where @@ -31,16 +33,16 @@ import Network.TLS.Record.State import Network.TLS.Types -getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) +getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) +getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getRxRecordState ctx = getXState ctx ctxRxRecordState getXState :: Context -> (Context -> MVar RecordState) - -> IO (Hash, Cipher, CryptLevel, ByteString) + -> IO (Hash, Cipher, CryptLevel, Secret) getXState ctx func = do tx <- readMVar (func ctx) let usedCipher = fromJust $ stCipher tx @@ -54,6 +56,12 @@ 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 @@ -66,7 +74,7 @@ return $ stCryptLevel tx class TrafficSecret ty where - fromTrafficSecret :: ty -> (CryptLevel, ByteString) + fromTrafficSecret :: ty -> (CryptLevel, Secret) instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s) @@ -103,7 +111,7 @@ -> Hash -> Cipher -> CryptLevel - -> ByteString + -> Secret -> IO () setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt) @@ -140,6 +148,9 @@ setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx) + +pushPendingRecvAction :: Context -> PendingRecvAction -> IO () +pushPendingRecvAction ctx a = modifyIORef' (ctxPendingRecvActions ctx) (a :) popPendingRecvAction :: Context -> IO (Maybe PendingRecvAction) popPendingRecvAction ctx = do diff --git a/Network/TLS/Handshake/TranscriptHash.hs b/Network/TLS/Handshake/TranscriptHash.hs --- a/Network/TLS/Handshake/TranscriptHash.hs +++ b/Network/TLS/Handshake/TranscriptHash.hs @@ -40,11 +40,11 @@ transit :: String -> Hash -> Bool -> TransHashState -> TransHashState transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0 transit _ _ _ st2@(TransHashState2 _) = st2 -transit _ hashAlg isHRR (TransHashState1 ch) - | isHRR = TransHashState2 $ newWith hsMsg - | otherwise = TransHashState2 $ newWith ch +transit _ hashAlg isHRR (TransHashState1 chs) + | isHRR = TransHashState2 $ hashUpdate (hashInit hashAlg) hsMsg + | otherwise = TransHashState2 $ hashUpdates (hashInit hashAlg) ch where - newWith = hashUpdate $ hashInit hashAlg + ch = reverse chs hsMsg = -- Handshake message: -- typ <-len-> body @@ -55,7 +55,7 @@ , hashedCH ] where - hashedCH = hash hashAlg ch + hashedCH = hashChunks hashAlg ch len = fromIntegral $ B.length hashedCH ---------------------------------------------------------------- @@ -73,9 +73,9 @@ traceTranscriptHash ctx label hstTransHashStateI update :: ByteString -> String -> TransHashState -> TransHashState -update eh _ TransHashState0 = TransHashState1 eh +update eh _ TransHashState0 = TransHashState1 [eh] +update eh _ (TransHashState1 bss) = TransHashState1 (eh : bss) update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh -update _ label st = error $ "updateTranscriptHash " ++ label ++ " " ++ show st ---------------------------------------------------------------- diff --git a/Network/TLS/HashAndSignature.hs b/Network/TLS/HashAndSignature.hs deleted file mode 100644 --- a/Network/TLS/HashAndSignature.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Network.TLS.HashAndSignature ( - HashAlgorithm ( - .., - HashNone, - HashMD5, - HashSHA1, - HashSHA224, - HashSHA256, - HashSHA384, - HashSHA512, - HashIntrinsic - ), - SignatureAlgorithm ( - .., - SignatureAnonymous, - SignatureRSA, - SignatureDSA, - SignatureECDSA, - SignatureRSApssRSAeSHA256, - SignatureRSApssRSAeSHA384, - SignatureRSApssRSAeSHA512, - SignatureEd25519, - SignatureEd448, - SignatureRSApsspssSHA256, - SignatureRSApsspssSHA384, - SignatureRSApsspssSHA512, - SignatureBrainpoolP256, - SignatureBrainpoolP384, - SignatureBrainpoolP512 - ), - HashAndSignatureAlgorithm, - supportedSignatureSchemes, - signatureSchemesForTLS13, -) 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 - -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 (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) - -{- FOURMOLU_DISABLE -} -supportedSignatureSchemes :: [HashAndSignatureAlgorithm] -supportedSignatureSchemes = - -- 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 = - -- 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/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -16,7 +16,7 @@ loadPacket13, ) where -import Control.Exception (finally, throwIO) +import qualified Control.Exception as E import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as B @@ -92,7 +92,7 @@ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx loop count | count > lim = do - let err = Error_Packet "too many handshake fragment" + let err = tooManyFragments logPacket ctx $ show err return $ Left err loop count = do @@ -102,8 +102,15 @@ Left err -> do logPacket ctx $ show err return $ Left err - Right record - | hrr && isCCS record -> loop (count + 1) + Right record@(Record _ _ fragment) + -- the ChangeCipherSpec after a HelloRetryRequest is skipped, + -- but checked like any other + | hrr && isCCS record -> + case checkChangeCipherSpec fragment of + Left err -> do + logPacket ctx $ show err + return $ Left err + Right _ -> loop (count + 1) | otherwise -> do pktRecv <- decodePacket12 ctx record if isEmptyHandshake pktRecv @@ -114,9 +121,10 @@ -- stHandshakeRecordCont loop (count + 1) else case pktRecv of - Right (Handshake hss) -> do - pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> - Right . Handshake <$> mapM (hookRecvHandshake hooks) hss + Right (Handshake hss bss) -> do + pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do + hss' <- mapM (hookRecvHandshake hooks) hss + return $ Right $ Handshake hss' bss logPacket ctx $ show pkt return pktRecv' Right pkt -> do @@ -126,12 +134,15 @@ logPacket ctx $ show err return pktRecv +tooManyFragments :: TLSError +tooManyFragments = Error_Protocol "too many handshake fragments" UnexpectedMessage + isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool -isEmptyHandshake (Right (Handshake [])) = True +isEmptyHandshake (Right (Handshake [] _)) = True isEmptyHandshake _ = False logPacket :: Context -> String -> IO () @@ -145,21 +156,10 @@ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx loop count | count > lim = - return $ Left $ Error_Packet "too many handshake fragment" + return $ Left tooManyFragments loop count = do erecord <- recordRecv13 recordLayer ctx case erecord of - Left err@(Error_Protocol _ BadRecordMac) -> do - -- If the server decides to reject RTT0 data but accepts RTT1 - -- data, the server should skip all records for RTT0 data. - logPacket ctx $ show err - established <- ctxEstablished ctx - case established of - EarlyDataNotAllowed n - | n > 0 -> do - setEstablished ctx $ EarlyDataNotAllowed (n - 1) - loop (count + 1) - _ -> return $ Left err Left err -> do logPacket ctx $ show err return $ Left err @@ -174,11 +174,15 @@ loop (count + 1) else do case pktRecv of - Right (Handshake13 hss) -> do - pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> - Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss + Right (Handshake13 hss bss) -> do + pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do + hss' <- mapM (hookRecvHandshake13 hooks) hss + return $ Right $ Handshake13 hss' bss logPacket ctx $ show pkt return pktRecv' + Right pkt@(AppData13 _) -> do + logPacket ctx $ show pkt + checkNotInterleaved ctx pktRecv Right pkt -> do logPacket ctx $ show pkt return pktRecv @@ -187,23 +191,41 @@ return pktRecv isEmptyHandshake13 :: Either TLSError Packet13 -> Bool -isEmptyHandshake13 (Right (Handshake13 [])) = True +isEmptyHandshake13 (Right (Handshake13 [] _)) = True isEmptyHandshake13 _ = False ---------------------------------------------------------------- +-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with +-- other record types. Application data that arrives while a handshake +-- message is still incomplete is refused with unexpected_message rather +-- than delivered. TLS 1.3 only: RFC 5246 Section 6.2.1 lets TLS 1.2 +-- interleave data of different content types. +checkNotInterleaved :: Context -> Either TLSError a -> IO (Either TLSError a) +checkNotInterleaved ctx pktRecv = do + complete <- isRecvComplete ctx + if complete + then return pktRecv + else do + let err = + Error_Packet_unexpected + "application data" + " expected: the rest of a handshake message" + logPacket ctx $ show err + return $ Left err + isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do cont12 <- gets stHandshakeRecordCont12 cont13 <- gets stHandshakeRecordCont13 - return $ isNothing cont12 && isNothing cont13 + return $ isNothing (fst cont12) && isNothing (fst cont13) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx - when (established == NotEstablished) $ throwIO ConnectionNotEstablished + when (established == NotEstablished) $ E.throwIO ConnectionNotEstablished eofed <- ctxEOF ctx - when eofed $ throwIO $ PostHandshake Error_EOF + when eofed $ E.throwIO $ PostHandshake Error_EOF ---------------------------------------------------------------- @@ -221,7 +243,8 @@ runPacketFlight :: Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a runPacketFlight ctx@Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do ref <- newIORef id - runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref + runReaderT f (recordLayer, ref) + `E.finally` sendPendingFlight ctx recordLayer ref sendPendingFlight :: Monoid b => Context -> RecordLayer b -> IORef (Builder b) -> IO () diff --git a/Network/TLS/IO/Decode.hs b/Network/TLS/IO/Decode.hs --- a/Network/TLS/IO/Decode.hs +++ b/Network/TLS/IO/Decode.hs @@ -3,10 +3,12 @@ module Network.TLS.IO.Decode ( decodePacket12, decodePacket13, + checkChangeCipherSpec, ) where import Control.Concurrent.MVar import Control.Monad.State.Strict +import qualified Data.ByteString as BS import Network.TLS.Cipher import Network.TLS.Context.Internal @@ -19,6 +21,7 @@ import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 +import Network.TLS.Types (Role (..)) import Network.TLS.Util import Network.TLS.Wire @@ -26,68 +29,128 @@ decodePacket12 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment decodePacket12 _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket12 ctx (Record ProtocolType_ChangeCipherSpec _ fragment) = - case decodeChangeCipherSpec $ fragmentGetBytes fragment of + case checkChangeCipherSpec fragment of Left err -> return $ Left err Right _ -> do - switchRxEncryption ctx - return $ Right ChangeCipherSpec + -- ChangeCipherSpec comes between complete handshake messages + -- (RFC 5246 Section 7.1), so not before the first ClientHello + -- of a server, which has no handshake state yet, nor in the + -- middle of a fragmented handshake message (CVE-2004-0079), + -- nor before the keys it switches to are computed. + mhs <- getHState ctx + (mCont, _) <- usingState_ ctx $ gets stHandshakeRecordCont12 + case mhs >>= hstPendingRxState of + Just rx | isNothing mCont -> do + modifyMVar_ (ctxRxRecordState ctx) (\_ -> return rx) + usingHState ctx $ modify' $ \hst -> hst{hstRxSwitched = True} + return $ Right ChangeCipherSpec + _ -> + return $ + Left $ + Error_Packet_unexpected "ChangeCipherSpec" " expected: handshake" +-- RFC 9846 Section 5.1: handshake records are never empty. The check +-- also keeps an empty one from ending the input of a partial message. +decodePacket12 _ (Record ProtocolType_Handshake _ fragment) + | BS.null (fragmentGetBytes fragment) = return $ Left emptyHandshake decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do - keyxchg <- - getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) + mhs <- getHState ctx + let keyxchg = mhs >>= hstPendingCipher >>= Just . cipherKeyExchange usingState ctx $ do + role <- getRole let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg } + -- A server has no handshake state until its first ClientHello, + -- and that is the only message it may receive then (RFC 8446 + -- Section 4). Any other is answered with unexpected_message + -- before its body is decoded, rather than with whatever decoding + -- the body as that type gives. + expectClientHello = role == ServerRole && isNothing mhs + decode ty content + | expectClientHello && ty /= HandshakeType_ClientHello = + Left $ Error_Packet_unexpected (show ty) " expected: client hello" + | otherwise = decodeHandshake currentParams ty content -- get back the optional continuation, and parse as many handshake record as possible. - mCont <- gets stHandshakeRecordCont12 - modify' (\st -> st{stHandshakeRecordCont12 = Nothing}) - hss <- parseMany currentParams mCont (fragmentGetBytes fragment) - return $ Handshake hss + (mCont, wirebytes) <- gets stHandshakeRecordCont12 + modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])}) + (hss, bss) <- + unzip <$> parseMany decode mCont wirebytes (fragmentGetBytes fragment) + return $ Handshake hss bss where - parseMany currentParams mCont bs = + parseMany decode mCont wirebytes bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err - GotPartial cont -> - modify' (\st -> st{stHandshakeRecordCont12 = Just cont}) >> return [] + GotPartial cont -> do + modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)}) + return [] GotSuccess (ty, content) -> - either throwError (return . (: [])) $ decodeHandshake currentParams ty content + case decode ty content of + Left err -> throwError err + Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left -> - case decodeHandshake currentParams ty content of + case decode ty content of Left err -> throwError err - Right hh -> (hh :) <$> parseMany currentParams Nothing left -decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") + Right h -> do + hbs <- parseMany decode Nothing [] left + let len = BS.length bs - BS.length left + bs' = BS.take len bs + return ((h, reverse (bs' : wirebytes)) : hbs) +decodePacket12 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty -switchRxEncryption :: Context -> IO () -switchRxEncryption ctx = - usingHState ctx (gets hstPendingRxState) >>= \rx -> - modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx) +emptyHandshake :: TLSError +emptyHandshake = Error_Protocol "empty handshake record" UnexpectedMessage ---------------------------------------------------------------- decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13) decodePacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) = - case decodeChangeCipherSpec $ fragmentGetBytes fragment of + case checkChangeCipherSpec fragment of Left err -> return $ Left err Right _ -> return $ Right ChangeCipherSpec13 decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment)) +decodePacket13 _ (Record ProtocolType_Handshake _ fragment) + | BS.null (fragmentGetBytes fragment) = return $ Left emptyHandshake decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do - mCont <- gets stHandshakeRecordCont13 - modify' (\st -> st{stHandshakeRecordCont13 = Nothing}) - hss <- parseMany mCont (fragmentGetBytes fragment) - return $ Handshake13 hss + (mCont, wirebytes) <- gets stHandshakeRecordCont13 + modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])}) + (hss, bss) <- unzip <$> parseMany mCont wirebytes (fragmentGetBytes fragment) + return $ Handshake13 hss bss where - parseMany mCont bs = + parseMany mCont wirebytes bs = case fromMaybe decodeHandshakeRecord13 mCont bs of GotError err -> throwError err - GotPartial cont -> - modify' (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return [] + GotPartial cont -> do + modify' (\st -> st{stHandshakeRecordCont13 = (Just cont, bs : wirebytes)}) + return [] GotSuccess (ty, content) -> - either throwError (return . (: [])) $ decodeHandshake13 ty content + case decodeHandshake13 ty content of + Left err -> throwError err + Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left -> case decodeHandshake13 ty content of Left err -> throwError err - Right hh -> (hh :) <$> parseMany Nothing left -decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") + Right h -> do + hbs <- parseMany Nothing [] left + let len = BS.length bs - BS.length left + bs' = BS.take len bs + return ((h, reverse (bs' : wirebytes)) : hbs) +decodePacket13 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty + +-- RFC 8446 Section 5: a record of an unexpected type, including the inner +-- type of a TLS 1.3 record, is answered with unexpected_message. +unknownProtocolType :: ProtocolType -> TLSError +unknownProtocolType ty = Error_Packet_unexpected (show ty) " expected: TLS record type" + +-- | A ChangeCipherSpec is the single byte 1. RFC 8446 Section 5 answers any +-- other value with unexpected_message, and TLS 1.2, which does not say, +-- is answered the same way: a record of two of them included. +checkChangeCipherSpec :: Fragment a -> Either TLSError () +checkChangeCipherSpec fragment = + case decodeChangeCipherSpec $ fragmentGetBytes fragment of + Left _ -> + Left $ + Error_Packet_unexpected "ChangeCipherSpec" " expected: the single byte 1" + Right _ -> Right () diff --git a/Network/TLS/IO/Encode.hs b/Network/TLS/IO/Encode.hs --- a/Network/TLS/IO/Encode.hs +++ b/Network/TLS/IO/Encode.hs @@ -2,7 +2,9 @@ encodePacket12, encodePacket13, updateTranscriptHash12, + encodeUpdateTranscriptHash12, updateTranscriptHash13, + encodeUpdateTranscriptHash13, ) where import Control.Concurrent.MVar @@ -47,8 +49,8 @@ -- packets are not fragmented here but by callers of sendPacket, so that the -- empty-packet countermeasure may be applied to each fragment independently. packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString] -packetToFragments12 ctx mlen (Handshake hss) = - getChunks mlen . B.concat <$> mapM (updateTranscriptHash12 ctx) hss +packetToFragments12 ctx mlen (Handshake hss _) = + getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash12 ctx) hss packetToFragments12 _ _ (Alert a) = return [encodeAlerts a] packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments12 _ _ (AppData x) = return [x] @@ -73,17 +75,32 @@ where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) -updateTranscriptHash12 :: Context -> Handshake -> IO ByteString -updateTranscriptHash12 ctx hs = do +encodeUpdateTranscriptHash12 :: Context -> Handshake -> IO ByteString +encodeUpdateTranscriptHash12 ctx hs = do when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded let label = show $ typeOfHandshake hs when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded + when (isClientHello hs) $ do + usingHState ctx $ do + (ch, b) <- fromJust <$> getClientHello + when (null b) $ setClientHello ch [encoded] return encoded where encoded = encodeHandshake hs + isClientHello (ClientHello _) = True + isClientHello _ = False +updateTranscriptHash12 :: Context -> HandshakeR -> IO () +updateTranscriptHash12 ctx (hs, bss) = do + when (certVerifyHandshakeMaterial hs) $ + usingHState ctx $ + mapM_ addHandshakeMessage bss + let label = show $ typeOfHandshake hs + when (finishedHandshakeMaterial hs) $ do + mapM_ (updateTranscriptHash ctx label) bss + ---------------------------------------------------------------- encodePacket13 @@ -100,14 +117,14 @@ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx) packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString] -packetToFragments13 ctx mlen (Handshake13 hss) = - getChunks mlen . B.concat <$> mapM (updateTranscriptHash13 ctx) hss +packetToFragments13 ctx mlen (Handshake13 hss _) = + getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash13 ctx) hss packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a] packetToFragments13 _ _ (AppData13 x) = return [x] packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec] -updateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString -updateTranscriptHash13 ctx hs +encodeUpdateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString +encodeUpdateTranscriptHash13 ctx hs | isIgnored hs = return encoded | otherwise = do let label = show $ typeOfHandshake13 hs @@ -117,6 +134,15 @@ where encoded = encodeHandshake13 hs - isIgnored NewSessionTicket13{} = True - isIgnored KeyUpdate13{} = True - isIgnored _ = False +updateTranscriptHash13 :: Context -> Handshake13R -> IO () +updateTranscriptHash13 ctx (hs, bss) + | isIgnored hs = return () + | otherwise = do + let label = show $ typeOfHandshake13 hs + mapM_ (updateTranscriptHash ctx label) bss + usingHState ctx $ mapM_ addHandshakeMessage bss + +isIgnored :: Handshake13 -> Bool +isIgnored NewSessionTicket13{} = True +isIgnored KeyUpdate13{} = True +isIgnored _ = False diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -14,6 +14,7 @@ sendPacket12, recvPacket12, makeCipherShowPretty, + paddingIsValid, ) where import Data.IORef @@ -25,6 +26,7 @@ import Network.TLS.IO.Encode import Network.TLS.Packet import Network.TLS.Packet13 +import Network.TLS.Record.Decrypt (paddingIsValid) import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types diff --git a/Network/TLS/KeySchedule.hs b/Network/TLS/KeySchedule.hs --- a/Network/TLS/KeySchedule.hs +++ b/Network/TLS/KeySchedule.hs @@ -8,7 +8,7 @@ import qualified Crypto.Hash as H import Crypto.KDF.HKDF -import Data.ByteArray (convert) +import Data.ByteArray (ByteArray, ByteArrayAccess, convert) import qualified Data.ByteString as BS import Network.TLS.Crypto @@ -20,7 +20,8 @@ -- | @HKDF-Extract@ function. Returns the pseudorandom key (PRK) from salt and -- input keying material (IKM). -hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString +hkdfExtract + :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba -> ba hkdfExtract SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) hkdfExtract SHA256 salt ikm = convert (extract salt ikm :: PRK H.SHA256) hkdfExtract SHA384 salt ikm = convert (extract salt ikm :: PRK H.SHA384) @@ -29,7 +30,7 @@ ---------------------------------------------------------------- -deriveSecret :: Hash -> ByteString -> ByteString -> TranscriptHash -> ByteString +deriveSecret :: Hash -> Secret -> ByteString -> TranscriptHash -> Secret deriveSecret h secret label (TranscriptHash hashedMsgs) = hkdfExpandLabel h secret label hashedMsgs outlen where @@ -40,12 +41,13 @@ -- | @HKDF-Expand-Label@ function. Returns output keying material of the -- specified length from the PRK, customized for a TLS label and context. hkdfExpandLabel - :: Hash - -> ByteString + :: (ByteArray ba, ByteArrayAccess ba) + => Hash + -> Secret -> ByteString -> ByteString -> Int - -> ByteString + -> ba hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do @@ -53,7 +55,8 @@ putOpaque8 ("tls13 " `BS.append` label) putOpaque8 ctx -expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString +expand' + :: (ByteArray ba, ByteArrayAccess ba) => Hash -> Secret -> ByteString -> Int -> ba expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len expand' SHA256 secret label len = expand (extractSkip secret :: PRK H.SHA256) label len expand' SHA384 secret label len = expand (extractSkip secret :: PRK H.SHA384) label len diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -6,24 +6,25 @@ prf_SHA256, prf_TLS, prf_MD5SHA1, + PRF, ) where -import qualified Data.ByteArray as B (xor) -import qualified Data.ByteString as B +import Data.ByteArray (ByteArray, ByteArrayAccess) +import qualified Data.ByteArray as BA import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types -type HMAC = ByteString -> ByteString -> ByteString +type HMAC = Secret -> ByteString -> Secret macSSL :: Hash -> HMAC macSSL alg secret msg = f $ - B.concat + BA.concat [ secret - , B.replicate padLen 0x5c - , f $ B.concat [secret, B.replicate padLen 0x36, msg] + , BA.replicate padLen 0x5c + , f $ BA.concat [secret, BA.replicate padLen 0x36, BA.convert msg] ] where padLen = case alg of @@ -32,49 +33,51 @@ _ -> error ("internal error: macSSL called with " ++ show alg) f = hash alg -hmac :: Hash -> HMAC -hmac alg secret msg = f $ B.append opad (f $ B.append ipad msg) +hmac :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ByteString -> ba +hmac alg secret msg = f $ BA.append opad (f $ BA.append ipad $ BA.convert msg) where - opad = B.map (xor 0x5c) k' - ipad = B.map (xor 0x36) k' + opad = BA.map (0x5c `xor`) k' + ipad = BA.map (0x36 `xor`) k' f = hash alg bl = hashBlockSize alg - k' = B.append kt pad + k' = BA.append kt pad where - kt = if B.length secret > fromIntegral bl then f secret else secret - pad = B.replicate (fromIntegral bl - B.length kt) 0 + kt = if BA.length secret > fromIntegral bl then f secret else secret + pad = BA.replicate (fromIntegral bl - BA.length kt) 0 hmacIter - :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] + :: HMAC -> Secret -> ByteString -> ByteString -> Int -> [Secret] hmacIter f secret seed aprev len = let an = f secret aprev - in let out = f secret (B.concat [an, seed]) - in let digestsize = B.length out + in let out = f secret (BA.concat [an, BA.convert seed]) + in let digestsize = BA.length out in if digestsize >= len - then [B.take (fromIntegral len) out] - else out : hmacIter f secret seed an (len - digestsize) + then [BA.take (fromIntegral len) out] + else out : hmacIter f secret seed (BA.convert an) (len - digestsize) -prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString -prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len +type PRF = Secret -> ByteString -> Int -> Secret -prf_MD5 :: ByteString -> ByteString -> Int -> ByteString -prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len +prf_SHA1 :: PRF +prf_SHA1 secret seed len = BA.concat $ hmacIter (hmac SHA1) secret seed seed len -prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString +prf_MD5 :: PRF +prf_MD5 secret seed len = BA.concat $ hmacIter (hmac MD5) secret seed seed len + +prf_MD5SHA1 :: PRF prf_MD5SHA1 secret seed len = - B.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) + BA.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) where - slen = B.length secret - s1 = B.take (slen `div` 2 + slen `mod` 2) secret - s2 = B.drop (slen `div` 2) secret + slen = BA.length secret + s1 = BA.take (slen `div` 2 + slen `mod` 2) secret + s2 = BA.drop (slen `div` 2) secret -prf_SHA256 :: ByteString -> ByteString -> Int -> ByteString -prf_SHA256 secret seed len = B.concat $ hmacIter (hmac SHA256) secret seed seed len +prf_SHA256 :: PRF +prf_SHA256 secret seed len = BA.concat $ hmacIter (hmac SHA256) secret seed seed len -- | For now we ignore the version, but perhaps some day the PRF will depend -- not only on the cipher PRF algorithm, but also on the protocol version. -prf_TLS :: Version -> Hash -> ByteString -> ByteString -> Int -> ByteString +prf_TLS :: Version -> Hash -> PRF prf_TLS _ halg secret seed len = - B.concat $ hmacIter (hmac halg) secret seed seed len + BA.concat $ hmacIter (hmac halg) secret seed seed len diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -40,8 +40,8 @@ generateKeyBlock, -- * for extensions parsing - getSignatureHashAlgorithm, - putSignatureHashAlgorithm, + getSignatureScheme, + putSignatureScheme, getBinaryVersion, putBinaryVersion, getClientRandom32, @@ -61,8 +61,7 @@ getPRF, ) where -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteArray as B (convert) +import Data.ByteArray (ByteArrayAccess, convert) import qualified Data.ByteString as B import Data.X509 ( CertificateChain, @@ -77,6 +76,7 @@ import Network.TLS.Struct import Network.TLS.Types import Network.TLS.Util.ASN1 +import Network.TLS.Util.Serialization (os2ip) import Network.TLS.Wire ---------------------------------------------------------------- @@ -158,12 +158,33 @@ decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType - content <- getOpaque24 + len <- getWord24 + -- Before the bytes, not after: the length is in the first four octets, so + -- refusing here is refusing to hold anything. Reassembly keeps every + -- fragment until the message is whole, and the peer picks the number it + -- announces. + when (len > maxHandshakeSize) $ + fail $ + "handshake message of " + ++ show len + ++ " octets exceeds the limit of " + ++ show maxHandshakeSize + content <- getBytes len return (ty, content) {- FOURMOLU_DISABLE -} decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake +-- A ClientKeyExchange is only expected once a cipher, and with it a key +-- exchange, has been negotiated; one that comes without -- after Finished, +-- say -- is out of order rather than malformed. +decodeHandshake cp HandshakeType_ClientKeyXchg + | isNothing (cParamsKeyXchgType cp) = + const $ + Left $ + Error_Packet_unexpected + (show HandshakeType_ClientKeyXchg) + " expected: no ClientKeyExchange before a key exchange is negotiated" decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello False @@ -192,6 +213,10 @@ session <- getSession ciphers <- map CipherId <$> getWords16 compressions <- getWords8 + -- cipher_suites<2..2^16-2> and compression_methods<1..2^8-1>: an empty + -- one is decode_error, not handshake_failure or illegal_parameter. + when (null ciphers) $ fail "no cipher suites" + when (null compressions) $ fail "no compression methods" r <- remaining exts <- if r > 0 @@ -254,7 +279,12 @@ Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) Right cc -> return $ Certificate $ CertificateChain_ cc where - getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) + getCertRaw = do + cert <- getOpaque24 + -- ASN.1Cert<1..2^24-1>: an empty one is decode_error, not + -- bad_certificate. + when (B.null cert) $ fail "empty certificate" + return (3 + B.length cert, cert) ---- @@ -310,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)) ---- @@ -338,8 +368,19 @@ parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic parseCKE _ = fail "unsupported client key exchange type" - parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16 - parseClientECDHPublic = CKX_ECDH <$> getOpaque8 + -- RFC 5246 Section 7.4.7.2: dh_Yc is <1..2^16-1>, so an empty one is + -- malformed, a decode_error, before it is a public value that is not + -- valid. + parseClientDHPublic = do + bs <- getOpaque16 + when (B.null bs) $ fail "empty DH public key" + return $ CKX_DH $ dhPublic $ os2ip bs + -- RFC 8422 Section 5.7: ecdh_Yc is <1..2^8-1>, so an empty one is + -- malformed, a decode_error, before it is a point that does not decode. + parseClientECDHPublic = do + bs <- getOpaque8 + when (B.null bs) $ fail "empty ECDH public key" + return $ CKX_ECDH bs decodeFinished :: Get Handshake decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes) @@ -389,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 @@ -489,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 ------------------------------------------------------------ @@ -518,7 +554,7 @@ -- ECParameters ECCurveType: curve name type grp <- Group <$> getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint - case decodeGroupPublic grp mxy of + case groupDecodePublicA grp mxy of Left e -> fail $ "getServerECDHParams: " ++ show e Right grppub -> return $ ServerECDHParams grp grppub _ -> fail "getServerECDHParams: unknown type for ECDH Params" @@ -528,19 +564,19 @@ putServerECDHParams (ServerECDHParams (Group grp) grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 grp -- ECParameters NamedCurve - putOpaque8 $ encodeGroupPublic grppub -- ECPoint + putOpaque8 $ groupEncodePublicA grppub -- ECPoint ------------------------------------------------------------ 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 ------------------------------------------------------------ @@ -556,8 +592,6 @@ ------------------------------------------------------------ -- generate things for packet content -type PRF = ByteString -> ByteString -> Int -> ByteString - -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getPRF :: Version -> Cipher -> PRF @@ -567,25 +601,23 @@ | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMainSecret_TLS - :: ByteArrayAccess preMain - => PRF - -> preMain + :: PRF + -> Secret -> ClientRandom -> ServerRandom - -> ByteString + -> Secret generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) = - prf (B.convert preMainSecret) seed 48 + prf preMainSecret seed 48 where seed = B.concat ["master secret", c, s] generateMainSecret - :: ByteArrayAccess preMain - => Version + :: Version -> Cipher - -> preMain + -> Secret -> ClientRandom -> ServerRandom - -> ByteString + -> Secret generateMainSecret v c = generateMainSecret_TLS $ getPRF v c generateExtendedMainSecret @@ -594,14 +626,14 @@ -> Cipher -> preMain -> ByteString - -> ByteString + -> Secret generateExtendedMainSecret v c preMainSecret sessionHash = - getPRF v c (B.convert preMainSecret) seed 48 + getPRF v c (convert preMainSecret) seed 48 where seed = B.append "extended master secret" sessionHash generateKeyBlock_TLS - :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString + :: PRF -> ClientRandom -> ServerRandom -> Secret -> Int -> Secret generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize = prf mainSecret seed kbsize where @@ -612,9 +644,9 @@ -> Cipher -> ClientRandom -> ServerRandom - -> ByteString + -> Secret -> Int - -> ByteString + -> Secret generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c ------------------------------------------------------------ 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 @@ -116,7 +116,18 @@ decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do ty <- getHandshakeType - content <- getOpaque24 + len <- getWord24 + -- Before the bytes, not after: the length is in the first four octets, so + -- refusing here is refusing to hold anything. Reassembly keeps every + -- fragment until the message is whole, and the peer picks the number it + -- announces. + when (len > maxHandshakeSize) $ + fail $ + "handshake message of " + ++ show len + ++ " octets exceeds the limit of " + ++ show maxHandshakeSize + content <- getBytes len return (ty, content) {- FOURMOLU_DISABLE -} @@ -182,6 +193,8 @@ where getCert = do l <- fromIntegral <$> getWord24 + -- ASN.1Cert<1..2^24-1>: see decodeCertificate. + when (l == 0) $ fail "empty certificate" cert <- getBytes l len <- fromIntegral <$> getWord16 exts <- getExtensions len @@ -196,7 +209,7 @@ decodeCertVerify13 :: Get Handshake13 decodeCertVerify13 = - CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16) + CertVerify13 <$> (DigitallySigned <$> getSignatureScheme <*> getOpaque16) decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes) @@ -209,25 +222,39 @@ 1 -> return $ KeyUpdate13 UpdateRequested x -> fail $ "Unknown request_update: " ++ show x +-- RFC 8879 Section 4: a certificate that cannot be decompressed, or whose +-- decompressed length is not the declared one, is answered with +-- bad_certificate, and an algorithm that was not offered with +-- illegal_parameter. errorToAlert tells them apart by the messages below. +-- A message that is malformed as a whole -- an empty +-- compressed_certificate_message, which its <1..2^24-1> bound forbids, or +-- bytes beyond the declared length -- is a decode_error, and is found +-- before anything is decompressed. decodeCompressedCertificate13 :: Get Handshake13 decodeCompressedCertificate13 = do algo <- getWord16 - when (algo /= 1) $ fail "comp algo is not supported" -- fixme + when (algo /= 1) $ fail "unsupported certificate compression algorithm" -- fixme len <- getWord24 bs <- getOpaque24 + left <- remaining + when (left /= 0) $ fail "bytes after compressed certificate" if bs == "" then fail "empty compressed certificate" - else case decompressIt bs of - Left e -> fail (show e) + else case decompressIt len bs of + Left e -> fail $ "certificate cannot be decompressed: " ++ show e Right bs' -> do - when (B.length bs' /= len) $ fail "plain length is wrong" + when (B.length bs' /= len) $ + fail "certificate cannot be decompressed: wrong uncompressed_length" case runGetMaybe decodeCertificate13 bs' of Just (Certificate13 reqctx certs ess) -> return $ CompressedCertificate13 reqctx certs ess -- _ -> fail "compressed certificate cannot be parsed" _ -> fail $ "invalid compressed certificate: len = " ++ show len -decompressIt :: ByteString -> Either DecompressError ByteString -decompressIt inp = unsafePerformIO $ E.handle handler $ do - Right . BL.toStrict <$> E.evaluate (decompress (BL.fromStrict inp)) +decompressIt :: Int -> ByteString -> Either DecompressError ByteString +decompressIt limit inp = unsafePerformIO $ E.handle handler $ do + -- One extra byte distinguishes exact-length output from oversized output. + let output = BL.take (fromIntegral limit + 1) $ decompress $ BL.fromStrict inp + Right <$> E.evaluate (BL.toStrict output) where - handler e = return $ Left (e :: DecompressError) + handler :: DecompressError -> IO (Either DecompressError ByteString) + handler e = return $ Left e 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) @@ -65,7 +66,7 @@ -- -- Default: 'Nothing' , debugPrintSeed :: Seed -> IO () - -- ^ Add a way to print the seed that was randomly generated. re-using the same seed + -- ^ Add a way to print the seed that was randomly generated. reusing the same seed -- will reproduce the same randomness with 'debugSeed' -- -- Default: no printing @@ -153,6 +154,16 @@ -- specified for TLS 1.2 but only the first entry is used. -- -- Default: '[]' + , clientWantTicket :: Bool + -- ^ Whether to solicit TLS 1.2 session tickets (or TLS 1.3 + -- resumption PSKs) from servers. With a 'False' setting, + -- stateless clients that never do resumption can avoid + -- wasting server and client resources used to generate, + -- transmit and process tickets that will never be used. + -- + -- Default: 'True' + -- + -- @since 2.4.1 , clientShared :: Shared -- ^ See the default value of 'Shared'. , clientHooks :: ClientHooks @@ -192,6 +203,7 @@ , clientUseServerNameIndication = True , clientWantSessionResume = Nothing , clientWantSessionResumeList = [] + , clientWantTicket = True , clientShared = def , clientHooks = def , clientSupported = def @@ -233,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 @@ -274,7 +291,7 @@ -- the server side, the highest version that is less or equal than -- the client version will be chosen. -- - -- Versions should be listed in preference order, i.e. higher + -- Versions should be listed in preferred order, i.e. higher -- versions first. -- -- Default: @[TLS13,TLS12]@ @@ -285,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 @@ -292,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. @@ -311,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 @@ -373,10 +415,23 @@ -- secure, but might help in rare cases. -- -- Default: 'True' + , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)] + -- ^ Client only. + -- + -- @since 2.1.9 , supportedGroups :: [Group] -- ^ A list of supported elliptic curves and finite-field groups - -- in the preferred order. + -- in preferred order. -- + -- * TLS 1.3 client: this list is used as the 1st argument to + -- 'onSelectKeyShareGroups' to select groups in "key_share". + -- This list is also used as values of "supported_groups". + -- * TLS 1.3 server: this list is not used. + -- * TLS 1.2 client: this list is also used as values of + -- "supported_groups". + -- * TLS 1.2 server: this list is used to select a key exchange + -- mechanism. + -- -- The list is sent to the server as part of the -- "supported_groups" extension. It is used in both clients and -- servers to restrict accepted groups in DH key exchange. Up @@ -386,11 +441,18 @@ -- The default value includes all groups with security strength -- of 128 bits or more. -- - -- Default: @[X25519,X448,P256,FFDHE2048,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ - , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)] - -- ^ Client only. + -- Default: @[X25519,P256,P384,X448,P521,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192,X25519MLKEM768,P256MLKEM768,P384MLKEM1024,MLKEM768,MLKEM1024]@ + , supportedGroupsTLS13 :: [[Group]] + -- ^ The inside @[Group]@ is the list of @Group@ at the same level + -- in preferred order. The inside @[Group]@s are also listed in + -- preferred order. -- - -- @since 2.1.9 + -- TLS 1.3 server: this is used as the 1st argument to + -- 'onSelectKeyShare'. + -- + -- Default: @[[X25519MLKEM768,P256MLKEM768,P384MLKEM1024],[X25519,P256],[P384,X448,P521],[FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192],[MLKEM768,MLKEM1024]]@ + -- + -- @since 2.2.3 } deriving (Show, Eq) @@ -419,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 @@ -427,8 +495,9 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True - , supportedGroups = supportedNamedGroups , supportedHPKE = defaultHPKE + , supportedGroups = supportedNamedGroups + , supportedGroupsTLS13 = supportedNamedGroupsTLS13 } instance Default Supported where @@ -534,7 +603,7 @@ -- document readable. type OnCertificateRequest = ( [CertificateType] - , Maybe [HashAndSignatureAlgorithm] + , Maybe [SignatureScheme] , [DistinguishedName] ) -> IO (Maybe (CertificateChain, PrivKey)) @@ -579,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 @@ -592,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 @@ -608,10 +684,11 @@ -- "Data.X509.Validation". This can be replaced with a custom -- validation function using different settings. -- - -- The function is not expected to verify the key-usage extension - -- of the end-entity certificate, as this depends on the - -- dynamically-selected cipher and this part should not be cached. - -- Key-usage verification is performed by the library internally. + -- The function is not expected to verify the key-usage or + -- extended-key-usage extensions of the end-entity certificate. + -- Key usage depends on the dynamically-selected cipher and this + -- part should not be cached. Both checks are performed by the + -- library internally after this function accepts the chain. -- -- Default: 'validateDefault' , onSuggestALPN :: IO (Maybe [ByteString]) @@ -637,11 +714,44 @@ -- (3) rejecting unless 1 < dh_p && pub < dh_p - 1 -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack) -- - -- See RFC 7919 section 3.1 for recommandations. + -- See RFC 7919 section 3.1 for recommendations. , onServerFinished :: Information -> IO () -- ^ When a handshake is done, this hook can check `Information`. + , onSelectKeyShareGroups :: [Group] -> [Group] + -- ^ A function to select groups in "key_share" by TLS 1.3 client. + -- + -- Client's 'supportedGroups' is passed as the 1st argument. + -- + -- The default function specifies a pair of hybrid (classical + + -- post quantum) group and classical group to transit from + -- classical key exchange to hybrid key exchange. With the + -- default value of 'supportedGroups', X25519MLKEM and X25519 + -- are chosen. + -- + -- Middleboxes may drop a ClientHello that contains large + -- X2219MLKEM. In such environment, @take 1@, which selects + -- X22519 only with the default value, is maybe a good + -- candidate. + -- + -- In the case where X22519 is only contained in "key_share", a + -- wise-server without nasty middleboxes may ask the client to + -- send X2219MLKEM via HelloRetryRequest as X2219MLKEM is + -- specified in "supported_groups". + -- + -- @since 2.2.3 } +defaultOnSelectKeyShareGroups :: [Group] -> [Group] +defaultOnSelectKeyShareGroups groups = take 1 hs ++ take 1 es + where + (hs, es) = partition isHybrid groups + +isHybrid :: Group -> Bool +isHybrid X25519MLKEM768 = True +isHybrid P256MLKEM768 = True +isHybrid P384MLKEM1024 = True +isHybrid _ = False + defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks @@ -650,6 +760,7 @@ , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024 , onServerFinished = \_ -> return () + , onSelectKeyShareGroups = defaultOnSelectKeyShareGroups } instance Show ClientHooks where @@ -668,7 +779,7 @@ -- of the certificate. This verification is performed by the -- library internally. -- - -- Default: returns the followings: + -- Default: returns the following: -- -- @ -- CertificateUsageReject (CertificateRejectOther "no client certificates expected") @@ -684,7 +795,7 @@ -- client version and the client list of ciphers. -- -- This could be useful with old clients and as a workaround to - -- the BEAST (where RC4 is sometimes prefered with TLS < 1.1) + -- the BEAST (where RC4 is sometimes preferred with TLS < 1.1) -- -- The client cipher list cannot be empty. -- @@ -719,6 +830,39 @@ -- of TLS 1.3. -- -- Default: 'return' + , onSelectKeyShare + :: [[Group]] + -> [Group] + -> [Group] + -> IO (Maybe Group, Bool) + -- ^ A function to select one key share by TLS 1.3 server. + -- + -- The 1st argument is server's 'supportedGroupsTLS13'. + -- The 2nd arguments is client's groups in "supported_groups" + -- The 3rd arguments is client's groups in "key_share". + -- + -- 'True' in the result indicates sending a hello retry request + -- with this group. + -- + -- The default function targets @[Group]@ in the first argument in + -- order. If there is a common group among the "key_share" + -- groups, it will use that group for key exchange. + -- Alternatively, if there is a common group among the + -- "supported_groups" groups, it will instruct to send the + -- HelloRetryRequest using that group. Otherwise, it will check + -- the next @[Group]@. + -- + -- @since 2.2.3 + , onAccept0RTT :: SessionData -> IO Bool + -- ^ Whether to accept 0-RTT with the session being resumed, once + -- everything else allows it. 'False' refuses the early data but not + -- the resumption. QUIC refuses 0-RTT when the transport parameters + -- it remembered do not hold any more (RFC 9000 Sec 7.4.1), and can + -- keep them in 'sessionAppData'. + -- + -- Default: @\_ -> return True@ + -- + -- @since 2.5.1 } -- | Default value for 'ServerHooks' @@ -737,6 +881,8 @@ , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing , onEncryptedExtensionsCreating = return + , onSelectKeyShare = defaultOnSelectKeyShare + , onAccept0RTT = \_ -> return True } instance Show ServerHooks where @@ -744,6 +890,20 @@ instance Default ServerHooks where def = defaultServerHooks +defaultOnSelectKeyShare + :: [[Group]] -- Server groups + -> [Group] -- Client's groups in "supported_groups" + -> [Group] -- Client's groups in "key_share" + -> IO (Maybe Group, Bool) +defaultOnSelectKeyShare serverSupportedLoL clientSupportedGroups clientKeyShareGroups = go serverSupportedLoL + where + go [] = return (Nothing, False) + go (gs : gss) = case gs `intersect` clientKeyShareGroups of + [] -> case gs `intersect` clientSupportedGroups of + [] -> go gss + h : _ -> return (Just h, True) + g : _ -> return (Just g, False) + -- | Information related to a running context, e.g. current cipher data Information = Information { infoVersion :: Version @@ -758,6 +918,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) @@ -778,11 +944,28 @@ -- -- Default: Nothing , limitHandshakeFragment :: Int - -- ^ The limit to accept the number of each handshake message. - -- For instance, a nasty client may send many fragments of client - -- certificate. + -- ^ The number of records that may carry a handshake message before + -- the one that completes it. A peer may split a message into records + -- as small as one byte, and each is held until the message is complete. -- - -- Default: 32 + -- Default: 2048 + , limitKeyUpdate :: Maybe Int + -- ^ Maximum number of consecutive TLS 1.3 KeyUpdate messages accepted + -- without intervening non-empty application data. This bounds the CPU + -- work and response amplification a peer can trigger while application + -- code is blocked inside 'recvData'. 'Nothing' and non-positive values + -- 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) @@ -791,5 +974,7 @@ defaultLimit = Limit { limitRecordSize = Nothing - , limitHandshakeFragment = 32 + , 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,19 +17,38 @@ ---------------------------------------------------------------- -- | 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 -- lock is already taken. Client only. -postHandshakeAuthWith :: Context -> Handshake13 -> IO () -postHandshakeAuthWith ctx hs = +postHandshakeAuthWith :: Context -> Handshake13R -> IO () +postHandshakeAuthWith ctx hb = withWriteLock ctx $ handleException ctx $ - doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs + doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hb diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -116,7 +116,7 @@ { quicSend :: [(CryptLevel, ByteString)] -> IO () -- ^ Called by TLS so that QUIC sends one or more handshake fragments. The -- content transiting on this API is the plaintext of the fragments and - -- QUIC responsability is to encrypt this payload with the key material + -- QUIC responsibility is to encrypt this payload with the key material -- given for the specified level and an appropriate encryption scheme. -- -- The size of the fragments may exceed QUIC datagram limits so QUIC may @@ -194,7 +194,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $ - Error_Protocol "QUIC transport parameters are mssing" MissingExtension + Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -222,7 +222,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $ - Error_Protocol "QUIC transport parameters are mssing" MissingExtension + Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo) diff --git a/Network/TLS/Record/Decrypt.hs b/Network/TLS/Record/Decrypt.hs --- a/Network/TLS/Record/Decrypt.hs +++ b/Network/TLS/Record/Decrypt.hs @@ -2,11 +2,13 @@ module Network.TLS.Record.Decrypt ( decryptRecord, + paddingIsValid, ) where import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..)) -import qualified Data.ByteArray as B (convert, xor) +import Data.ByteArray (convert) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher @@ -41,7 +43,13 @@ Left message -> throwError $ Error_Protocol message UnexpectedMessage Right (ct', d) -> return $ Record ct' ver $ fragmentPlaintext d ProtocolType_ChangeCipherSpec -> noDecryption - ProtocolType_Alert -> noDecryption + -- A peer that fails before it has keys answers in clear, but after + -- the handshake an alert in clear can only be forged (RFC 8446 + -- Section 5). + ProtocolType_Alert + | stCryptLevel st == CryptApplicationSecret -> + throwError $ Error_Protocol "alert in clear" UnexpectedMessage + | otherwise -> noDecryption _ -> throwError $ Error_Protocol "illegal plain text" UnexpectedMessage @@ -52,31 +60,38 @@ Just (bytes, c) | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes -> Left ("empty " ++ show (ProtocolType c) ++ " record disallowed") + -- RFC 9846 Section 5: change_cipher_spec is only sent in clear. + | ProtocolType c == ProtocolType_ChangeCipherSpec -> + Left "protected change_cipher_spec" | otherwise -> Right (ProtocolType c, bytes) where (dc, _pad) = B.spanEnd (== 0) inner nonEmptyContentTypes = [ProtocolType_Handshake, ProtocolType_Alert] unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c -getCipherData :: Record a -> CipherData -> RecordM ByteString -getCipherData (Record pt ver _) cdata = do +-- | Check a decrypted record. +-- +-- The first 'Bool' is what the lengths and the padding already said: 'False' +-- when the padding the record claims cannot be one or is not filled with its +-- length. It is carried in rather than answered where it was found, so that +-- the MAC is computed either way -- see 'decryptData'. +-- +-- Everything is computed before anything is decided, and the verdicts are +-- combined with '&&!', which does not short-circuit. +getCipherData :: Record a -> Bool -> CipherData -> RecordM ByteString +getCipherData (Record pt ver _) lengthValid cdata = do -- check if the MAC is valid. macValid <- case cipherDataMAC cdata of Nothing -> return True Just digest -> do let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) expected_digest <- makeDigest new_hdr $ cipherDataContent cdata - return (expected_digest == digest) - - -- check if the padding is filled with the correct pattern if it exists - -- (before TLS10 this checks instead that the padding length is minimal) - paddingValid <- case cipherDataPadding cdata of - Nothing -> return True - Just (pad, _blksz) -> do - let b = B.length pad - 1 - return $ B.replicate (B.length pad) (fromIntegral b) == pad + -- constEq rather than (==): (==) on ByteString is memcmp, which + -- returns as soon as two octets differ, and how soon is a + -- measurement of how much of the MAC was guessed correctly. + return (expected_digest `BA.constEq` digest) - unless (macValid &&! paddingValid) $ + unless (lengthValid &&! macValid) $ throwError $ Error_Protocol "bad record mac Stream/Block" BadRecordMac @@ -114,9 +129,13 @@ blockSize = bulkBlockSize bulk econtentLen = B.length econtent + -- A record too short for the cipher cannot be deprotected: RFC 5246 + -- Section 7.2.2 and RFC 8446 Section 5.2 answer it with bad_record_mac. sanityCheckError = - throwError - (Error_Packet "encrypted content too small for encryption parameters") + throwError $ + Error_Protocol + "encrypted content too small for encryption parameters" + BadRecordMac decryptOf :: BulkState -> RecordM ByteString decryptOf (BulkStateBlock decryptF) = do @@ -133,16 +152,34 @@ let (content', iv') = decryptF iv econtent' modify' $ \txs -> txs{stCryptState = cst{cstIV = iv'}} - let paddinglength = fromIntegral (B.last content') + 1 - let contentlen = B.length content' - paddinglength - macSize - (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength) - getCipherData - record - CipherData - { cipherDataContent = content - , cipherDataMAC = Just mac - , cipherDataPadding = Just (padding, blockSize) - } + -- The last octet of the plaintext says how much padding there is. + -- It may say more than the record can hold, and that already settles + -- the record -- but answering it here, by splitting the record and + -- failing, would answer it *without computing the MAC*. How long a + -- record takes to reject would then say whether the padding length + -- was plausible, which is the question the attacker is asking. + -- + -- So carry the verdict instead and go on with a length that fits. + -- getCipherData folds it in with the MAC, and the answer is the same + -- BadRecordMac either way. + let plainlen = B.length content' + claimed = fromIntegral (B.last content') + 1 + lengthValid = claimed + macSize <= plainlen + paddinglength = if lengthValid then claimed else 1 + contentlen = plainlen - paddinglength - macSize + paddingValid = paddingIsValid content' paddinglength + -- Lucky Thirteen: the rounds a longer padding saves on the MAC. + dummy = hmacDummyRounds (cipherHash cipher) contentlen (plainlen - 1 - macSize) + (content, mac, _) <- get3i content' (contentlen, macSize, paddinglength) + dummy `seq` + getCipherData + record + (lengthValid &&! paddingValid) + CipherData + { cipherDataContent = content + , cipherDataMAC = Just mac + , cipherDataPadding = Nothing + } decryptOf (BulkStateStream (BulkStream decryptF)) = do -- check if we have enough bytes to cover the minimum for this cipher when (econtentLen < macSize) sanityCheckError @@ -154,6 +191,7 @@ modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}} getCipherData record + True CipherData { cipherDataContent = content , cipherDataMAC = Just mac @@ -180,11 +218,11 @@ | otherwise = B.concat [encodedSeq, encodeHeader hdr] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce - | nonceExpLen == 0 = B.xor iv sqnc + | nonceExpLen == 0 = BA.xor iv sqnc | otherwise = iv `B.append` enonce (content, authTag2) = decryptF nonce econtent' ad - when (AuthTag (B.convert authTag) /= authTag2) $ + when (AuthTag (convert authTag) /= authTag2) $ throwError $ Error_Protocol "bad record mac on AEAD" BadRecordMac @@ -193,9 +231,11 @@ decryptOf BulkStateUninitialized = throwError $ Error_Protocol "decrypt state uninitialized" InternalError - -- handling of outer format can report errors with Error_Packet + -- the outer format of a record that cannot be deprotected is reported + -- as an integrity failure too, i.e. BadRecordMac get3o s ls = - maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls + maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ + partition3 s ls get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) -- all format errors related to decrypted content are reported @@ -204,3 +244,35 @@ maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ partition3 s ls get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) + +-- | Whether the last @padLen@ octets of the plaintext all equal its last +-- octet. All 256 octets a padding can span are read, whatever @padLen@. +paddingIsValid :: ByteString -> Int -> Bool +paddingIsValid plain padLen = go 0 0 == 0 + where + window = B.drop (B.length plain - 256) plain + wlen = B.length window + b = B.last plain + go :: Int -> Word8 -> Word8 + go i acc + | i == wlen = acc + | otherwise = + go (i + 1) $ acc .|. (inPadding i .&. (B.index window (wlen - 1 - i) `xor` b)) + -- 0xff for an octet less than padLen from the end, without a branch + inPadding i = fromIntegral ((i - padLen) `shiftR` (finiteBitSize i - 1)) + +-- | HMAC over a shorter content takes fewer compression rounds of the hash. +-- Spend the difference from the longest content on dummy blocks, so that a +-- record takes as long whatever its padding says. +hmacDummyRounds :: Hash -> Int -> Int -> ByteString +hmacDummyRounds h contentLen maxContentLen = + hash h $ B.take ((rounds maxContentLen - rounds contentLen) * bs) dummyBlocks + where + bs = hashBlockSize h + -- the ipad block, the sequence number and header, the content, and the + -- 0x80 octet and length field of the hash padding + rounds n = (bs + 13 + n + 1 + lengthField + bs - 1) `div` bs + lengthField = if bs == 128 then 16 else 8 + +dummyBlocks :: ByteString +dummyBlocks = B.replicate (8 * 128) 0 diff --git a/Network/TLS/Record/Encrypt.hs b/Network/TLS/Record/Encrypt.hs --- a/Network/TLS/Record/Encrypt.hs +++ b/Network/TLS/Record/Encrypt.hs @@ -13,7 +13,8 @@ import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..)) -import qualified Data.ByteArray as B (convert, xor) +import Data.ByteArray (convert) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher @@ -117,12 +118,12 @@ | otherwise = B.concat [encodedSeq, encodeHeader hdr] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce - | nonceExpLen == 0 = B.xor iv sqnc + | nonceExpLen == 0 = BA.xor iv sqnc | otherwise = B.concat [iv, encodedSeq] (e, AuthTag authtag) = encryptF nonce content ad econtent - | nonceExpLen == 0 = e `B.append` B.convert authtag - | otherwise = B.concat [encodedSeq, e, B.convert authtag] + | nonceExpLen == 0 = e `B.append` convert authtag + | otherwise = B.concat [encodedSeq, e, convert authtag] modify' incrRecordState return econtent diff --git a/Network/TLS/Record/Recv.hs b/Network/TLS/Record/Recv.hs --- a/Network/TLS/Record/Recv.hs +++ b/Network/TLS/Record/Recv.hs @@ -50,7 +50,8 @@ -- ^ TLS context -> IO (Either TLSError (Record Plaintext)) recvRecord12 ctx = - readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) + readExactBytes ctx 5 + >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType)) where recvLengthE = either (return . Left) recvLength @@ -69,7 +70,9 @@ >>= either (return . Left) (getRecord ctx header) recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext)) -recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) +recvRecord13 ctx = + readExactBytes ctx 5 + >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType)) where recvLengthE = either (return . Left) recvLength recvLength header@(Header _ _ readlen) = do @@ -86,10 +89,43 @@ then return $ Left maximumSizeExceeded else readExactBytes ctx (fromIntegral readlen) - >>= either (return . Left) (getRecord ctx header) + >>= either (return . Left) (getRecord13 header) + -- RFC 9846 Section 4.2.10: a server that rejected early data skips the + -- records it cannot deprotect, until the first one it can. + getRecord13 header@(Header ty _ readlen) content = do + erecord <- getRecord ctx header content + case erecord of + Left (Error_Protocol _ BadRecordMac) -> do + skipped <- skipEarlyData ctx (fromIntegral readlen) + if skipped then recvRecord13 ctx else return erecord + Right _ | ty == ProtocolType_AppData -> do + established <- ctxEstablished ctx + case established of + EarlyDataNotAllowed _ -> setEstablished ctx NotEstablished + _ -> return () + return erecord + _ -> return erecord maximumSizeExceeded :: TLSError maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow + +-- RFC 8446 Section 5: a record of an unexpected type is answered with +-- unexpected_message. Checked on the header, before the body is read, so +-- that what is no TLS record at all -- an SSLv2 ClientHello, say, whose first +-- byte reads as type 0x80 and whose length can ask for bytes that never +-- come -- is answered at once rather than when the peer gives up. +checkType :: Header -> Either TLSError Header +checkType header@(Header ty _ _) + | ty `elem` known = Right header + | otherwise = + Left $ Error_Packet_unexpected (show ty) " expected: TLS record type" + where + known = + [ ProtocolType_ChangeCipherSpec + , ProtocolType_Alert + , ProtocolType_Handshake + , ProtocolType_AppData + ] ---------------------------------------------------------------- diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -22,6 +22,7 @@ ) where import Control.Monad.State.Strict +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher @@ -36,10 +37,10 @@ data CryptState = CryptState { cstKey :: BulkState - , cstIV :: ByteString + , cstIV :: IV , -- In TLS 1.2 or earlier, this holds mac secret. -- In TLS 1.3, this holds application traffic secret N. - cstMacSecret :: ByteString + cstMacSecret :: Secret } deriving (Show) @@ -130,7 +131,7 @@ { stCipher = Nothing , stCompression = nullCompression , stCryptLevel = CryptInitial - , stCryptState = CryptState BulkStateUninitialized B.empty B.empty + , stCryptState = CryptState BulkStateUninitialized B.empty BA.empty , stMacState = MacState 0 } @@ -153,7 +154,7 @@ :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest _ver tstate hdr content = (digest, incrRecordState tstate) where - digest = macF (cstMacSecret cst) msg + digest = BA.convert $ macF (cstMacSecret cst) msg cst = stCryptState tstate cipher = fromJust $ stCipher tstate hashA = cipherHash cipher diff --git a/Network/TLS/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/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -25,6 +25,7 @@ setVersion, setVersionIfUnset, getVersion, + getVersionMaybe, getVersionWithDefault, setSecureRenegotiation, getSecureRenegotiation, @@ -79,7 +80,7 @@ import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct -import Network.TLS.Types (HostName, Role (..), Ticket) +import Network.TLS.Types (HostName, Role (..), Secret, Ticket, WireBytes) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState @@ -93,8 +94,10 @@ stServerCertificateChain :: Maybe CertificateChain , stExtensionALPN :: Bool -- RFC 7301 , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol - , stHandshakeRecordCont12 :: Maybe (GetContinuation (HandshakeType, ByteString)) - , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString)) + , stHandshakeRecordCont12 + :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes) + , stHandshakeRecordCont13 + :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes) , stClientALPNSuggest :: Maybe [ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] @@ -111,7 +114,7 @@ , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: Bool , stTLS13Cookie :: Maybe Cookie - , stTLS13ExporterSecret :: Maybe ByteString + , stTLS13ExporterSecret :: Maybe Secret , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } @@ -136,8 +139,8 @@ , stServerCertificateChain = Nothing , stExtensionALPN = False , stNegotiatedProtocol = Nothing - , stHandshakeRecordCont12 = Nothing - , stHandshakeRecordCont13 = Nothing + , stHandshakeRecordCont12 = (Nothing, []) + , stHandshakeRecordCont13 = (Nothing, []) , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing @@ -230,6 +233,14 @@ fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion +-- | The negotiated version, or 'Nothing' before there is one. +-- +-- 'getVersion' calls 'error' in that case, which is the right answer inside +-- the handshake -- reaching it there would be a bug -- and the wrong one for +-- anything a user of the library can call before the handshake has run. +getVersionMaybe :: TLSSt (Maybe Version) +getVersionMaybe = gets stVersion + getVersionWithDefault :: Version -> TLSSt Version getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion @@ -335,10 +346,10 @@ getTLS12SessionTicket :: TLSSt (Maybe Ticket) getTLS12SessionTicket = gets stTLS12SessionTicket -setTLS13ExporterSecret :: ByteString -> TLSSt () +setTLS13ExporterSecret :: Secret -> TLSSt () setTLS13ExporterSecret key = modify' (\st -> st{stTLS13ExporterSecret = Just key}) -getTLS13ExporterSecret :: TLSSt (Maybe ByteString) +getTLS13ExporterSecret :: TLSSt (Maybe Secret) getTLS13ExporterSecret = gets stTLS13ExporterSecret setTLS13KeyShare :: Maybe KeyShare -> TLSSt () diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -110,7 +110,7 @@ Handshake (..), packetType, typeOfHandshake, - module Network.TLS.HashAndSignature, + module Network.TLS.SignatureScheme, ExtensionRaw (..), ExtensionID (..), showCertificateChain, @@ -118,6 +118,7 @@ hrrRandom, ClientHello (..), ServerHello (..), + HandshakeR, ) where import Data.X509 ( @@ -133,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 @@ -197,7 +198,7 @@ type Signature = ByteString -data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature +data DigitallySigned = DigitallySigned SignatureScheme Signature deriving (Eq) instance Show DigitallySigned where @@ -231,14 +232,14 @@ ---------------------------------------------------------------- data Packet - = Handshake [Handshake] + = Handshake [Handshake] [WireBytes] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Eq) instance Show Packet where - show (Handshake hs) = "Handshake " ++ show hs + show (Handshake hs _) = "Handshake " ++ show hs show (Alert as) = "Alert " ++ show as show ChangeCipherSpec = "ChangeCipherSpec" show (AppData bs) = "AppData " ++ showBytesHex bs @@ -362,7 +363,7 @@ ---------------------------------------------------------------- -data ServerECDHParams = ServerECDHParams Group GroupPublic +data ServerECDHParams = ServerECDHParams Group GroupPublicA deriving (Show, Eq) ---------------------------------------------------------------- @@ -469,7 +470,7 @@ | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] - [HashAndSignatureAlgorithm] + [SignatureScheme] [DistinguishedName] | CertVerify DigitallySigned | Finished VerifyData @@ -478,7 +479,7 @@ {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType -packetType (Handshake _) = ProtocolType_Handshake +packetType (Handshake _ _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData @@ -496,3 +497,5 @@ typeOfHandshake Finished{} = HandshakeType_Finished typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket {- FOURMOLU_ENABLE -} + +type HandshakeR = (Handshake, WireBytes) diff --git a/Network/TLS/Struct13.hs b/Network/TLS/Struct13.hs --- a/Network/TLS/Struct13.hs +++ b/Network/TLS/Struct13.hs @@ -8,6 +8,7 @@ isKeyUpdate13, TicketNonce (..), SessionIDorTicket_ (..), + Handshake13R, ) where import Network.TLS.Imports @@ -15,7 +16,7 @@ import Network.TLS.Types data Packet13 - = Handshake13 [Handshake13] + = Handshake13 [Handshake13] [WireBytes] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString @@ -76,3 +77,5 @@ isKeyUpdate13 :: Handshake13 -> Bool isKeyUpdate13 (KeyUpdate13 _) = True isKeyUpdate13 _ = False + +type Handshake13R = (Handshake13, WireBytes) diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -11,7 +11,9 @@ bigNumToInteger, bigNumFromInteger, defaultRecordSizeLimit, + maxHandshakeSize, TranscriptHash (..), + WireBytes, ) where import Network.Socket (HostName) @@ -60,7 +62,27 @@ ---------------------------------------------------------------- +-- | The largest handshake message we will reassemble. +-- +-- A handshake message carries a 24-bit length, so a peer may announce close +-- to 16MB and then feed it a record at a time. Records are bounded, but the +-- message they are reassembled into was not, and the fragments are held until +-- it is complete -- before anything has authenticated the peer. +-- +-- The largest legitimate one is a Certificate message. A long chain of +-- post-quantum certificates runs to tens of kilobytes, so this leaves an +-- order of magnitude over anything real while taking two orders of magnitude +-- off what a peer can ask us to hold. +maxHandshakeSize :: Int +maxHandshakeSize = 262144 + +---------------------------------------------------------------- + newtype TranscriptHash = TranscriptHash ByteString instance Show TranscriptHash where show (TranscriptHash bs) = showBytesHex bs + +---------------------------------------------------------------- + +type WireBytes = [ByteString] diff --git a/Network/TLS/Types/Cipher.hs b/Network/TLS/Types/Cipher.hs --- a/Network/TLS/Types/Cipher.hs +++ b/Network/TLS/Types/Cipher.hs @@ -4,6 +4,7 @@ module Network.TLS.Types.Cipher where import Crypto.Cipher.Types (AuthTag) +import Data.ByteArray (ScrubbedBytes) import Data.IORef import GHC.Generics import System.IO.Unsafe (unsafePerformIO) @@ -15,6 +16,16 @@ ---------------------------------------------------------------- +type PlainText = ByteString +type CipherText = ByteString +type Secret = ScrubbedBytes +type Key = ScrubbedBytes +type IV = ByteString +type Nonce = ByteString -- aka IV +type AddDat = ByteString + +---------------------------------------------------------------- + -- | Cipher identification type CipherID = Word16 @@ -106,12 +117,12 @@ data BulkDirection = BulkEncrypt | BulkDecrypt deriving (Show, Eq) -type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV) - -type BulkKey = ByteString -type BulkIV = ByteString -type BulkNonce = ByteString +type BulkKey = Secret +type BulkIV = Nonce +type BulkNonce = Nonce type BulkAdditionalData = ByteString + +type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV) newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream)) diff --git a/Network/TLS/Types/Secret.hs b/Network/TLS/Types/Secret.hs --- a/Network/TLS/Types/Secret.hs +++ b/Network/TLS/Types/Secret.hs @@ -1,6 +1,17 @@ +-- | The secret types of the TLS key schedule. +-- +-- None of these prints its key material: 'Show' renders @\@, since +-- these values reach a QUIC implementation through +-- "Network.TLS.QUIC" and are the kind of thing a handshake trace prints +-- without meaning to. 'Crypto.Debug.debugShow' returns the hexadecimal that +-- 'Show' used to, for a debugging session that wants it. @SSLKEYLOGFILE@ +-- does not go through either: it uses 'Network.TLS.Handshake.Key.LogLabel'. module Network.TLS.Types.Secret where +import Crypto.Debug (DebugShow (..)) +import Data.ByteArray (convert) import Network.TLS.Imports +import Network.TLS.Types.Cipher -- | Phantom type indicating early traffic secret. data EarlySecret @@ -13,30 +24,42 @@ data ResumptionSecret -newtype BaseSecret a = BaseSecret ByteString +newtype BaseSecret a = BaseSecret Secret instance Show (BaseSecret a) where - show (BaseSecret bs) = showBytesHex bs + show _ = "" -newtype AnyTrafficSecret a = AnyTrafficSecret ByteString +instance DebugShow (BaseSecret a) where + debugShow (BaseSecret bs) = showBytesHex $ convert bs +newtype AnyTrafficSecret a = AnyTrafficSecret Secret + instance Show (AnyTrafficSecret a) where - show (AnyTrafficSecret bs) = showBytesHex bs + show _ = "" +instance DebugShow (AnyTrafficSecret a) where + debugShow (AnyTrafficSecret bs) = showBytesHex $ convert bs + -- | A client traffic secret, typed with a parameter indicating a step in the -- TLS key schedule. -newtype ClientTrafficSecret a = ClientTrafficSecret ByteString +newtype ClientTrafficSecret a = ClientTrafficSecret Secret instance Show (ClientTrafficSecret a) where - show (ClientTrafficSecret bs) = showBytesHex bs + show _ = "" +instance DebugShow (ClientTrafficSecret a) where + debugShow (ClientTrafficSecret bs) = showBytesHex $ convert bs + -- | A server traffic secret, typed with a parameter indicating a step in the -- TLS key schedule. -newtype ServerTrafficSecret a = ServerTrafficSecret ByteString +newtype ServerTrafficSecret a = ServerTrafficSecret Secret instance Show (ServerTrafficSecret a) where - show (ServerTrafficSecret bs) = showBytesHex bs + show _ = "" +instance DebugShow (ServerTrafficSecret a) where + debugShow (ServerTrafficSecret bs) = showBytesHex $ convert bs + data SecretTriple a = SecretTriple { triBase :: BaseSecret a , triClient :: ClientTrafficSecret a @@ -53,8 +76,22 @@ -- | 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 ByteString +newtype MainSecret = MainSecret Secret instance Show MainSecret where - show (MainSecret bs) = showBytesHex bs + show _ = "" + +instance DebugShow MainSecret where + debugShow (MainSecret bs) = showBytesHex $ convert bs diff --git a/Network/TLS/Types/Session.hs b/Network/TLS/Types/Session.hs --- a/Network/TLS/Types/Session.hs +++ b/Network/TLS/Types/Session.hs @@ -3,6 +3,7 @@ module Network.TLS.Types.Session where import Codec.Serialise +import Crypto.Debug (DebugShow (..)) import qualified Data.ByteString as B import GHC.Generics import Network.Socket (HostName) @@ -38,14 +39,85 @@ , sessionCipher :: CipherID , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName - , sessionSecret :: ByteString + , -- ScrubbedBytes is not an instance of Generic, sigh. + sessionSecret :: ByteString , sessionGroup :: Maybe Group , sessionTicketInfo :: Maybe TLS13TicketInfo , sessionALPN :: Maybe ByteString , sessionMaxEarlyDataSize :: Int , sessionFlags :: [SessionFlag] - } -- sessionFromTicket :: Bool - deriving (Show, Eq, Generic) + , 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. + , sessionAppData :: Maybe ByteString + -- ^ Data of the application's own, kept with the session and given + -- back on resumption; never set by this library. A server can put + -- what 0-RTT depends on here and check it in 'onAccept0RTT'. + -- + -- @since 2.5.1 + } + -- sessionFromTicket :: Bool + deriving (Eq, Generic) + +-- | Everything but @sessionSecret@, which renders as @\@: whoever +-- has it can resume the session. 'Crypto.Debug.debugShow' renders it. +instance Show SessionData where + showsPrec = showsSessionData (showString "") + +instance DebugShow SessionData where + debugShow sd = showsSessionData (shows $ sessionSecret sd) 0 sd "" + +-- | What the two instances above share, so that a field added to +-- 'SessionData' cannot reach one of them and not the other. +showsSessionData :: ShowS -> Int -> SessionData -> ShowS +showsSessionData secret d sd = + showParen (d > 10) $ + showString "SessionData {sessionVersion = " + . shows (sessionVersion sd) + . showString ", sessionCipher = " + . shows (sessionCipher sd) + . showString ", sessionCompression = " + . shows (sessionCompression sd) + . showString ", sessionClientSNI = " + . shows (sessionClientSNI sd) + . showString ", sessionSecret = " + . secret + . showString ", sessionGroup = " + . shows (sessionGroup sd) + . showString ", sessionTicketInfo = " + . shows (sessionTicketInfo sd) + . showString ", sessionALPN = " + . shows (sessionALPN sd) + . showString ", sessionMaxEarlyDataSize = " + . shows (sessionMaxEarlyDataSize sd) + . showString ", sessionFlags = " + . shows (sessionFlags sd) + . showString ", sessionClientCertificate = " + . showString (maybe "Nothing" derLength (sessionClientCertificate sd)) + . showString ", sessionAppData = " + . shows (sessionAppData 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. +defaultSessionData :: SessionData +defaultSessionData = + SessionData + { sessionVersion = TLS13 + , sessionCipher = 0 + , sessionCompression = 0 + , sessionClientSNI = Nothing + , sessionSecret = B.empty + , sessionGroup = Nothing + , sessionTicketInfo = Nothing + , sessionALPN = Nothing + , sessionMaxEarlyDataSize = 0 + , sessionFlags = [] + , sessionClientCertificate = Nothing + , sessionAppData = Nothing + } is0RTTPossible :: SessionData -> Bool is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0 diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.TLS.Util ( sub, @@ -17,8 +18,9 @@ ) where import Control.Concurrent.MVar -import Control.Exception (SomeAsyncException (..)) import qualified Control.Exception as E +import Data.ByteArray (ScrubbedBytes) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Imports @@ -46,18 +48,24 @@ (p3, _) = B.splitAt d3 r2 partition6 - :: ByteString + :: ScrubbedBytes -> (Int, Int, Int, Int, Int, Int) - -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString) -partition6 bytes (d1, d2, d3, d4, d5, d6) = if B.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6) + -> Maybe + ( ScrubbedBytes + , ScrubbedBytes + , ScrubbedBytes + , ScrubbedBytes + , ScrubbedBytes + , ScrubbedBytes + ) +partition6 bytes (d1, d2, d3, d4, d5, d6) = if BA.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6) where - s = sum [d1, d2, d3, d4, d5, d6] - (p1, r1) = B.splitAt d1 bytes - (p2, r2) = B.splitAt d2 r1 - (p3, r3) = B.splitAt d3 r2 - (p4, r4) = B.splitAt d4 r3 - (p5, r5) = B.splitAt d5 r4 - (p6, _) = B.splitAt d6 r5 + slice' (beg, len) = BA.unsafeSlice bytes beg len + lens = [d1, d2, d3, d4, d5, d6] + s = sum lens + begs = scanl (+) 0 lens + ys = zip begs lens + [p1, p2, p3, p4, p5, p6] = map slice' ys -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool @@ -74,7 +82,7 @@ where filterExn :: E.SomeException -> Maybe E.SomeException filterExn e = case E.fromException (E.toException e) of - Just (SomeAsyncException _) -> Nothing + Just (E.SomeAsyncException _) -> Nothing Nothing -> Just e forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b]) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -80,8 +80,14 @@ toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes")) toSimple (GotSuccess r) = Right r +-- | Nothing unless the whole input is consumed: data after an extension's +-- content, or any other structure decoded so, is a decode error. runGetMaybe :: Get a -> ByteString -> Maybe a -runGetMaybe f = either (const Nothing) Just . G.runGet f +runGetMaybe f = either (const Nothing) Just . G.runGet (f <* end) + where + end = do + r <- remaining + when (r /= 0) $ fail "trailing data" tryGet :: Get a -> ByteString -> Maybe a tryGet f = either (const Nothing) Just . G.runGet f diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -7,7 +7,7 @@ import qualified Data.ByteString as B import Data.List import Data.Word -import Data.X509 (ExtKeyUsageFlag) +import Data.X509 (ExtKeyUsageFlag, privkeyMLDSAFromKey) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Internal @@ -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 @@ -139,10 +139,12 @@ ---------------------------------------------------------------- arbitraryCiphersIds :: Gen [CipherId] -arbitraryCiphersIds = map CipherId <$> (choose (0, 200) >>= vector) +-- A ClientHello has at least one of each (cipher_suites<2..2^16-2>, +-- compression_methods<1..2^8-1>). +arbitraryCiphersIds = map CipherId <$> (choose (1, 200) >>= vector) arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0, 200) >>= vector +arbitraryCompressionIDs = choose (1, 200) >>= vector someWords8 :: Int -> Gen [Word8] someWords8 = vector @@ -222,6 +224,22 @@ , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) ] +-- | One credential per ML-DSA parameter set. +arbitraryCredentialsOfEachMLDSA :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachMLDSA = do + (pub44, priv44) <- arbitraryMLDSA44Pair + (pub65, priv65) <- arbitraryMLDSA65Pair + (pub87, priv87) <- arbitraryMLDSA87Pair + mapM + ( \(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) + [ (PubKeyMLDSA44 pub44, PrivKeyMLDSA44 (privkeyMLDSAFromKey priv44)) + , (PubKeyMLDSA65 pub65, PrivKeyMLDSA65 (privkeyMLDSAFromKey priv65)) + , (PubKeyMLDSA87 pub87, PrivKeyMLDSA87 (privkeyMLDSAFromKey priv87)) + ] + arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle @@ -380,8 +398,9 @@ { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg - , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures + , supportedGroups = serverGroups + , supportedGroupsTLS13 = [serverGroups] } , serverShared = defaultShared{sharedCredentials = Credentials creds} } diff --git a/test/Certificate.hs b/test/Certificate.hs --- a/test/Certificate.hs +++ b/test/Certificate.hs @@ -6,6 +6,7 @@ arbitraryX509, arbitraryX509WithKey, arbitraryX509WithKeyAndUsage, + arbitraryRSACredentialWithPurpose, arbitraryDN, simpleCertificate, simpleX509, @@ -118,6 +119,25 @@ let (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert return signedExact +arbitraryRSACredentialWithPurpose + :: ExtKeyUsagePurpose -> Gen (CertificateChain, PrivKey) +arbitraryRSACredentialWithPurpose purpose = do + let (pubKey, privKey) = getGlobalRSAPair + cert <- arbitraryCertificate knownKeyUsage $ PubKeyRSA pubKey + sig <- resize 40 $ listOf1 arbitrary + let cert' = + cert + { certExtensions = + Extensions $ + Just + [ extensionEncode True $ ExtKeyUsage knownKeyUsage + , extensionEncode False $ ExtExtendedKeyUsage [purpose] + ] + } + sigalg = getSignatureALG $ PubKeyRSA pubKey + (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert' + return (CertificateChain [signedExact], PrivKeyRSA privKey) + arbitraryX509 :: Gen SignedCertificate arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair @@ -139,6 +159,9 @@ getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 +getSignatureALG (PubKeyMLDSA44 _) = SignatureALG_IntrinsicHash PubKeyALG_MLDSA44 +getSignatureALG (PubKeyMLDSA65 _) = SignatureALG_IntrinsicHash PubKeyALG_MLDSA65 +getSignatureALG (PubKeyMLDSA87 _) = SignatureALG_IntrinsicHash PubKeyALG_MLDSA87 getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey diff --git a/test/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/CiphersSpec.hs b/test/CiphersSpec.hs --- a/test/CiphersSpec.hs +++ b/test/CiphersSpec.hs @@ -1,9 +1,11 @@ module CiphersSpec where +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Extra.Cipher +import Network.TLS.Internal (paddingIsValid) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -19,6 +21,17 @@ (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF iv t additional (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF t _ -> return () + describe "CBC padding" $ do + -- Read in constant time; the answer is still the plain one. + prop "is valid when the last octets equal the last" $ \(NonEmpty ws) (Positive n) -> do + let plain = B.pack ws + padLen = 1 + (n - 1) `mod` min 256 (B.length plain) + expected = B.all (== B.last plain) $ B.drop (B.length plain - padLen) plain + paddingIsValid plain padLen `shouldBe` expected + prop "accepts a padding filled with its length" $ \ws (Positive n) -> do + let len = (n - 1) `mod` 256 + plain = B.pack ws <> B.replicate (len + 1) (fromIntegral len) + paddingIsValid plain (len + 1) `shouldBe` True block :: BulkBlock @@ -52,8 +65,8 @@ decrypted `shouldBe` t at `shouldBe` at2 -arbitraryKey :: Bulk -> Gen B.ByteString -arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) +arbitraryKey :: Bulk -> Gen BA.ScrubbedBytes +arbitraryKey bulk = BA.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) @@ -61,7 +74,8 @@ arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) -data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString +data BulkTest + = BulkTest Bulk BA.ScrubbedBytes B.ByteString B.ByteString B.ByteString deriving (Show, Eq) instance Arbitrary BulkTest where diff --git a/test/ECHSpec.hs b/test/ECHSpec.hs --- a/test/ECHSpec.hs +++ b/test/ECHSpec.hs @@ -35,6 +35,19 @@ describe "ECH greasing" $ do prop "sends greasing ECH" handshake13_greasing prop "sends greasing ECH HRR" handshake13_greasing_hrr + describe "ECHConfigList decoding" $ do + it "decodes a list" $ + length <$> decodeECHConfigList echConfListRaw `shouldBe` Just 1 + it "refuses data after the list" $ + decodeECHConfigList (B.snoc echConfListRaw 0) `shouldBe` Nothing + it "refuses a config longer than its contents" $ + decodeECHConfigList (list [version13 <> opaque16 (B.snoc echConfBody 0)]) + `shouldBe` Nothing + it "refuses a config that runs past the list" $ + decodeECHConfigList (B.pack [0, 0x42] <> echConf) `shouldBe` Nothing + it "ignores a config of an unknown version" $ + decodeECHConfigList (list [B.pack [0xfe, 0x0e] <> opaque16 "x", echConf]) + `shouldBe` decodeECHConfigList echConfListRaw -------------------------------------------------------------- @@ -56,6 +69,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params = setParams @@ -75,6 +89,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params = setParams @@ -94,6 +109,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params0 = setParams @@ -126,6 +142,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params0 = setParams @@ -162,6 +179,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params0 = setParams @@ -187,6 +205,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_CCM_SHA256] , supportedGroups = [P256] + , supportedGroupsTLS13 = [[P256]] } runTLSSimple13ECH (cli2, srv2') HelloRetryRequest @@ -202,6 +221,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } cliHooks = defaultClientHooks @@ -256,6 +276,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group0] + , supportedGroupsTLS13 = [[group0]] } params = setParams @@ -286,6 +307,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group1] + , supportedGroupsTLS13 = [[group1]] } params1 = ( pc{clientUseEarlyData = True} @@ -319,7 +341,11 @@ EC cgrps <- generate arbitrary EC sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps} - svrSupported = (serverSupported srv){supportedGroups = sgrps} + svrSupported = + (serverSupported srv) + { supportedGroups = sgrps + , supportedGroupsTLS13 = [sgrps] + } params = setParams ( cli{clientSupported = cliSupported} @@ -332,7 +358,12 @@ FFDHE cgrps <- generate arbitrary FFDHE sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps} - svrSupported = (serverSupported srv){supportedGroups = sgrps} + svrSupported = + (serverSupported srv) + { supportedGroups = sgrps + , supportedGroupsTLS13 = [sgrps] + } + params = setParams ( cli{clientSupported = cliSupported} @@ -351,6 +382,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params = ( cli @@ -379,6 +411,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] } params = ( cli @@ -419,8 +452,20 @@ echKey = [(0, B64.decodeLenient "GAl/YqzDDnssODe5t+2xlQsbSv26kNlfJ0D+nZbK62I=")] echConfList :: ECHConfigList -echConfList = - fromJust $ - decodeECHConfigList $ - B64.decodeLenient - "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA" +echConfList = fromJust $ decodeECHConfigList echConfListRaw + +-- An ECHConfigList of one ECHConfig, its version and its contents. +echConfListRaw, echConf, version13, echConfBody :: ByteString +echConfListRaw = + B64.decodeLenient + "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA" +echConf = B.drop 2 echConfListRaw +version13 = B.take 2 echConf +echConfBody = B.drop 4 echConf + +opaque16 :: ByteString -> ByteString +opaque16 bs = + B.pack [fromIntegral (B.length bs `div` 256), fromIntegral (B.length bs)] <> bs + +list :: [ByteString] -> ByteString +list = opaque16 . B.concat diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -1,8 +1,18 @@ module EncodeSpec where +import Codec.Compression.Zlib (compress) +import Control.Exception (bracket_, evaluate) +import Control.Monad (forM_, void) import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Either (isLeft) +import Data.Int (Int64) +import Data.Word (Word16, Word8) +import GHC.Conc (disableAllocationLimit, enableAllocationLimit, setAllocationCounter) import Network.TLS import Network.TLS.Internal +import Network.TLS.QUIC (errorToAlertDescription) import Test.Hspec import Test.Hspec.QuickCheck @@ -10,6 +20,48 @@ spec :: Spec spec = do + describe "extension decoding" $ do + prop "yields Nothing rather than throwing, for any message type" $ + \ws -> forM_ extensionDecoders $ \(name, decode) -> + forM_ [minBound .. maxBound] $ \mt -> + decode mt (B.pack ws) `shouldReturn` name + describe "handshake record length" $ do + -- A handshake message carries a 24-bit length, and the fragments are + -- held until the message is whole. Refusing at the header means + -- refusing to hold anything: the length arrives in the first four + -- octets, before any of the body. + it "refuses a length past the limit, on its header alone" $ do + let tooBig = maxHandshakeSize + 1 + isGotError (decodeHandshakeRecord (handshakeHeader tooBig)) `shouldBe` True + isGotError (decodeHandshakeRecord13 (handshakeHeader tooBig)) `shouldBe` True + it "refuses the largest a 24-bit length can say" $ do + let header = handshakeHeader 0xffffff + isGotError (decodeHandshakeRecord header) `shouldBe` True + isGotError (decodeHandshakeRecord13 header) `shouldBe` True + -- Still waiting for the body rather than refusing it: at the limit + -- the header alone is not enough to decide anything is wrong. + it "asks for more at the limit itself" $ do + let header = handshakeHeader maxHandshakeSize + isGotPartial (decodeHandshakeRecord header) `shouldBe` True + isGotPartial (decodeHandshakeRecord13 header) `shouldBe` True + it "still decodes a message of an ordinary size" $ do + let body = B.replicate 1000 0 + record = handshakeHeader (B.length body) `B.append` body + gotThisMuch (B.length body) (decodeHandshakeRecord record) `shouldBe` True + gotThisMuch (B.length body) (decodeHandshakeRecord13 record) `shouldBe` True + + describe "extension trailing data" $ do + it "refuses data after the content of an extension" $ + filter (not . snd) trailingCases `shouldBe` [] + + describe "ClientHello decoding" $ do + it "refuses empty cipher_suites" $ + clientHelloAlert [] [0] `shouldBe` Just DecodeError + it "refuses empty compression_methods" $ + clientHelloAlert [0x1301] [] `shouldBe` Just DecodeError + it "decodes one of each" $ + clientHelloAlert [0x1301] [0] `shouldBe` Nothing + describe "encoder/decoder" $ do prop "can encode/decode Header" $ \x -> do decodeHeader (encodeHeader x) `shouldBe` Right x @@ -17,7 +69,195 @@ decodeHs (encodeHandshake x) `shouldBe` Right x prop "can encode/decode Handshake13" $ \x -> do decodeHs13 (encodeHandshake13 x) `shouldBe` Right x + it "round trips a valid TLS 1.3 compressed certificate" $ do + let certificate = + CompressedCertificate13 + B.empty + (CertificateChain_ $ CertificateChain []) + [] + decodeHs13 (encodeHandshake13 certificate) `shouldBe` Right certificate + it "rejects decompressed output shorter than its declared size" $ do + let plain = encodeCertificate13 B.empty (CertificateChain []) [] + compressed = BL.toStrict $ compress $ BL.fromStrict plain + encoded = runPut $ do + putWord16 1 + putWord24 (B.length plain + 1) + putOpaque24 compressed + decodeHandshake13 HandshakeType_CompressedCertificate encoded + `shouldSatisfy` isLeft + -- RFC 8879 Section 4: a CompressedCertificate that cannot be + -- decompressed, or whose decompressed length is not the one + -- declared, is answered with bad_certificate; one with an algorithm + -- that was not offered breaks no decoding rule but a field value, + -- and is answered with illegal_parameter. One malformed as a whole + -- stays a decode_error. + it "answers a decompressed length mismatch with bad_certificate" $ do + let plain = encodeCertificate13 B.empty (CertificateChain []) [] + compressed = BL.toStrict $ compress $ BL.fromStrict plain + compressedCertificateAlert 1 (B.length plain + 1) compressed + `shouldBe` Just BadCertificate + it "answers data that is not zlib with bad_certificate" $ + compressedCertificateAlert 1 16 (B.replicate 16 0xff) + `shouldBe` Just BadCertificate + it "answers an empty compressed certificate with decode_error" $ + compressedCertificateAlert 1 16 B.empty + `shouldBe` Just DecodeError + it "answers bytes after a compressed certificate with decode_error" $ do + let plain = encodeCertificate13 B.empty (CertificateChain []) [] + compressed = BL.toStrict $ compress $ BL.fromStrict plain + either (Just . errorToAlertDescription) (const Nothing) + ( decodeHandshake13 HandshakeType_CompressedCertificate $ + runPut $ do + putWord16 1 + putWord24 (B.length plain) + putOpaque24 (B.drop 2 compressed) + putBytes (B.take 2 compressed) + ) + `shouldBe` Just DecodeError + it "answers an unsupported compression algorithm with illegal_parameter" $ do + let plain = encodeCertificate13 B.empty (CertificateChain []) [] + compressed = BL.toStrict $ compress $ BL.fromStrict plain + compressedCertificateAlert 2 (B.length plain) compressed + `shouldBe` Just IllegalParameter + -- A ClientKeyExchange is only expected once a cipher, and with it a + -- key exchange, has been negotiated -- not, say, after Finished. + -- One that comes without is out of order: unexpected_message. + it "answers a ClientKeyExchange before a key exchange with unexpected_message" $ + either (Just . errorToAlertDescription) (const Nothing) + ( decodeHandshake + CurrentParams{cParamsVersion = TLS12, cParamsKeyXchgType = Nothing} + HandshakeType_ClientKeyXchg + (B.replicate 130 1) + ) + `shouldBe` Just UnexpectedMessage + -- RFC 7301 Section 3.1: protocol_name_list<2..2^16-1> of + -- ProtocolName<1..2^8-1>. + it "refuses a malformed application_layer_protocol_negotiation" $ + forM_ + [ B.empty -- empty extension + , B.pack [0, 0] -- empty list + , B.pack [0, 1, 0] -- empty ProtocolName + , B.pack [0, 2, 1, 104, 2, 104, 50] -- trailing data + ] + $ \bs -> + ( extensionDecode MsgTClientHello bs + :: Maybe ApplicationLayerProtocolNegotiation + ) + `shouldBe` Nothing + it "decodes an application_layer_protocol_negotiation" $ + ( extensionDecode MsgTClientHello (B.pack [0, 3, 2, 104, 50]) + :: Maybe ApplicationLayerProtocolNegotiation + ) + `shouldBe` Just (ApplicationLayerProtocolNegotiation [B.pack [104, 50]]) + -- RFC 8422 Section 5.7: ecdh_Yc is <1..2^8-1>, so an empty one is + -- malformed -- a decode_error -- rather than a point that does not + -- decode, which is an illegal_parameter. + it "answers an empty ECDH public key with decode_error" $ + either (Just . errorToAlertDescription) (const Nothing) + ( decodeHandshake + CurrentParams + { cParamsVersion = TLS12 + , cParamsKeyXchgType = Just CipherKeyExchange_ECDHE_RSA + } + HandshakeType_ClientKeyXchg + (B.singleton 0) + ) + `shouldBe` Just DecodeError + -- RFC 5246 Section 7.4.7.2: dh_Yc is <1..2^16-1>, so an empty one is + -- malformed -- a decode_error -- rather than a public value that is + -- not valid, which is an illegal_parameter. + -- RFC 6066 Section 3: server_name_list<1..2^16-1> of + -- HostName<1..2^16-1>. + it "refuses a malformed server_name in ClientHello" $ + forM_ + [ B.empty -- empty extension + , B.pack [0, 0] -- empty list + , B.pack [0, 3, 0, 0, 0] -- empty host_name + , B.pack [0, 4, 0, 0, 1, 101, 120] -- trailing data + ] + $ \bs -> + (extensionDecode MsgTClientHello bs :: Maybe ServerName) + `shouldBe` Nothing + it "decodes a server_name in ClientHello" $ + (extensionDecode MsgTClientHello (B.pack [0, 4, 0, 0, 1, 101]) :: Maybe ServerName) + `shouldBe` Just (ServerName [ServerNameHostName "e"]) + it "answers an empty DH public key with decode_error" $ + either (Just . errorToAlertDescription) (const Nothing) + ( decodeHandshake + CurrentParams + { cParamsVersion = TLS12 + , cParamsKeyXchgType = Just CipherKeyExchange_DHE_RSA + } + HandshakeType_ClientKeyXchg + (B.pack [0, 0]) + ) + `shouldBe` Just DecodeError + it "bounds TLS 1.3 certificate decompression by the declared size" $ do + let compressed = BL.toStrict $ compress $ BL.replicate (32 * 1024 * 1024) 0 + encoded = runPut $ do + putWord16 1 + putWord24 1 + putOpaque24 compressed + _ <- evaluate $ B.length encoded + decoded <- + withinAllocationLimit (8 * 1024 * 1024) $ + evaluate $ + decodeHandshake13 HandshakeType_CompressedCertificate encoded + decoded `shouldSatisfy` isLeft +compressedCertificateAlert :: Word16 -> Int -> ByteString -> Maybe AlertDescription +compressedCertificateAlert algo len compressed = + either (Just . errorToAlertDescription) (const Nothing) $ + decodeHandshake13 HandshakeType_CompressedCertificate $ + runPut $ do + putWord16 algo + putWord24 len + putOpaque24 compressed + +-- | Each extension decodes as encoded, and not with a byte appended. +trailingCases :: [(String, Bool)] +trailingCases = + [ ch "supported_groups" $ SupportedGroups [X25519] + , ch "signature_algorithms" $ SignatureAlgorithms [RSA_PSS_RSAE_SHA256] + , ch "application_layer_protocol_negotiation" $ + ApplicationLayerProtocolNegotiation [B.pack [0x68, 0x32]] + , ch "record_size_limit" $ RecordSizeLimit 16385 + , ch "supported_versions" $ SupportedVersionsClientHello [TLS13] + , ch "psk_key_exchange_modes" $ PskKeyExchangeModes [PSK_DHE_KE] + , ch "key_share" $ KeyShareClientHello [KeyShareEntry X25519 (B.replicate 32 1)] + , ch "early_data" $ EarlyDataIndication Nothing + , ch "post_handshake_auth" PostHandshakeAuth + , ch "renegotiation_info" $ SecureRenegotiation B.empty B.empty + , + ( "early_data in NewSessionTicket" + , refused MsgTNewSessionTicket $ EarlyDataIndication (Just 1) + ) + , ("cookie in ServerHello", refused MsgTServerHello $ Cookie (B.pack [1, 2, 3])) + ] + where + ch name e = (name, refused MsgTClientHello e) + refused :: (Extension e, Eq e) => MessageType -> e -> Bool + refused mt e = decode bs == Just e && decode (B.snoc bs 0) == Nothing + where + bs = extensionEncode e + decode b = extensionDecode mt b `asTypeOf` Just e + +-- | Decodes a ClientHello without extensions and returns its alert, if any. +clientHelloAlert :: [Word16] -> [Word8] -> Maybe AlertDescription +clientHelloAlert ciphers comps = + either (Just . errorToAlertDescription) (const Nothing) $ + decodeHandshake cp HandshakeType_ClientHello $ + runPut $ do + putWord16 0x0303 + putBytes $ B.replicate 32 0 + putWord8 0 + putWord16 $ fromIntegral $ 2 * length ciphers + mapM_ putWord16 ciphers + putWord8 $ fromIntegral $ length comps + mapM_ putWord8 comps + where + cp = CurrentParams{cParamsVersion = TLS12, cParamsKeyXchgType = Nothing} + decodeHs :: ByteString -> Either TLSError Handshake decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b where @@ -30,6 +270,28 @@ decodeHs13 :: ByteString -> Either TLSError Handshake13 decodeHs13 b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b +-- | A handshake record header: a type octet then a 24-bit length. +handshakeHeader :: Int -> ByteString +handshakeHeader len = + B.pack + [ 1 -- ClientHello + , fromIntegral (len `div` 65536) + , fromIntegral ((len `div` 256) `mod` 256) + , fromIntegral (len `mod` 256) + ] + +isGotError :: GetResult a -> Bool +isGotError (GotError _) = True +isGotError _ = False + +isGotPartial :: GetResult a -> Bool +isGotPartial (GotPartial _) = True +isGotPartial _ = False + +gotThisMuch :: Int -> GetResult (a, ByteString) -> Bool +gotThisMuch n (GotSuccess (_, content)) = B.length content == n +gotThisMuch _ _ = False + verifyResult :: (f -> r -> a) -> GetResult (f, r) -> a verifyResult fn result = case result of @@ -37,3 +299,48 @@ GotError e -> error ("got error: " ++ show e) GotSuccessRemaining _ _ -> error "got remaining byte left" GotSuccess (ty, content) -> fn ty content + +withinAllocationLimit :: Int64 -> IO a -> IO a +withinAllocationLimit limit = + bracket_ + (setAllocationCounter limit >> enableAllocationLimit) + disableAllocationLimit + +-- | Every 'Extension' instance, each wrapped so that the decoded value is +-- forced inside IO. A partial 'extensionDecode' therefore surfaces as a +-- thrown exception the test can see, rather than as a thunk nobody looks at. +-- +-- The name is threaded through as the return value only so that a failure +-- report says which instance it was. +type Decoder a = MessageType -> ByteString -> Maybe a + +extensionDecoders :: [(String, MessageType -> ByteString -> IO String)] +extensionDecoders = + [ + entry "ServerName" (extensionDecode :: Decoder ServerName), + entry "MaxFragmentLength" (extensionDecode :: Decoder MaxFragmentLength), + entry "SecureRenegotiation" (extensionDecode :: Decoder SecureRenegotiation), + entry "ApplicationLayerProtocolNegotiation" (extensionDecode :: Decoder ApplicationLayerProtocolNegotiation), + entry "ExtendedMainSecret" (extensionDecode :: Decoder ExtendedMainSecret), + entry "CompressCertificate" (extensionDecode :: Decoder CompressCertificate), + entry "SupportedGroups" (extensionDecode :: Decoder SupportedGroups), + entry "EcPointFormatsSupported" (extensionDecode :: Decoder EcPointFormatsSupported), + entry "RecordSizeLimit" (extensionDecode :: Decoder RecordSizeLimit), + entry "SessionTicket" (extensionDecode :: Decoder SessionTicket), + entry "HeartBeat" (extensionDecode :: Decoder HeartBeat), + entry "SignatureAlgorithms" (extensionDecode :: Decoder SignatureAlgorithms), + entry "SignatureAlgorithmsCert" (extensionDecode :: Decoder SignatureAlgorithmsCert), + entry "SupportedVersions" (extensionDecode :: Decoder SupportedVersions), + entry "KeyShare" (extensionDecode :: Decoder KeyShare), + entry "PostHandshakeAuth" (extensionDecode :: Decoder PostHandshakeAuth), + entry "PskKeyExchangeModes" (extensionDecode :: Decoder PskKeyExchangeModes), + entry "PreSharedKey" (extensionDecode :: Decoder PreSharedKey), + entry "EarlyDataIndication" (extensionDecode :: Decoder EarlyDataIndication), + entry "Cookie" (extensionDecode :: Decoder Cookie), + entry "CertificateAuthorities" (extensionDecode :: Decoder CertificateAuthorities), + entry "EchOuterExtensions" (extensionDecode :: Decoder EchOuterExtensions), + entry "EncryptedClientHello" (extensionDecode :: Decoder EncryptedClientHello) + ] + where + entry name decode = (name, \mt bs -> name <$ evaluate (length (show (decode mt bs)))) + diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -2,1017 +2,4445 @@ module HandshakeSpec where -import Control.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.IORef -import Data.List -import Data.Maybe -import Data.X509 (ExtKeyUsageFlag (..)) -import Network.TLS -import Network.TLS.Extra.Cipher -import Network.TLS.Internal -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck - -import API -import Arbitrary -import PipeChan -import Run -import Session - -spec :: Spec -spec = do - describe "pipe" $ do - it "can setup a channel" pipe_work - describe "handshake" $ do - prop "can run TLS 1.2" handshake_simple - prop "can run TLS 1.3" handshake13_simple - prop "can update key for TLS 1.3" handshake_update_key - prop "can prevent downgrade attack" handshake13_downgrade - prop "can negotiate hash and signature" handshake_hashsignatures - prop "can negotiate cipher suite" handshake_ciphersuites - prop "can negotiate group" handshake_groups - prop "can negotiate elliptic curve" handshake_ec - prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher - prop - "can fallback for certificate with hash and signature" - handshake_cert_fallback_hs - prop "can handle server key usage" handshake_server_key_usage - prop "can handle client key usage" handshake_client_key_usage - prop "can authenticate client" handshake_client_auth - prop "can receive client authentication failure" handshake_client_auth_fail - prop "can handle extended main secret" handshake_ems - prop "can resume with extended main secret" handshake_resumption_ems - prop "can handle ALPN" handshake_alpn - prop "can handle SNI" handshake_sni - prop "can re-negotiate with TLS 1.2" handshake12_renegotiation - prop "can resume session with TLS 1.2" handshake12_session_resumption - prop "can resume session ticket with TLS 1.2" handshake12_session_ticket - prop "can handshake with TLS 1.3 Full" handshake13_full - prop "can handshake with TLS 1.3 HRR" handshake13_hrr - prop "can handshake with TLS 1.3 PSK" handshake13_psk - prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket - prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback - prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt - prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback - prop "can handshake with TLS 1.3 EE" handshake13_ee_groups - prop "can handshake with TLS 1.3 EC groups" handshake13_ec - prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe - prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth - --------------------------------------------------------------- - -pipe_work :: IO () -pipe_work = do - pipe <- newPipe - _ <- runPipe pipe - - let bSize = 16 - n <- generate (choose (1, 32)) - - let d1 = B.replicate (bSize * n) 40 - let d2 = B.replicate (bSize * n) 45 - - d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1) - d1' `shouldBe` d1 - - d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2) - d2' `shouldBe` d2 - --------------------------------------------------------------- - -handshake_simple :: (ClientParams, ServerParams) -> IO () -handshake_simple = runTLSSimple - --------------------------------------------------------------- - -newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) - -instance Arbitrary CSP13 where - arbitrary = CSP13 <$> arbitraryPairParams13 - -handshake13_simple :: CSP13 -> IO () -handshake13_simple (CSP13 params) = runTLSSimple13 params hs - where - cgrps = supportedGroups $ clientSupported $ fst params - sgrps = supportedGroups $ serverSupported $ snd params - hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest - --------------------------------------------------------------- - -handshake13_downgrade :: (ClientParams, ServerParams) -> IO () -handshake13_downgrade (cparam, sparam) = do - versionForced <- - generate $ elements (supportedVersions $ clientSupported cparam) - let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} - sparam' = sparam{serverDebug = debug'} - params = (cparam, sparam') - downgraded = - (isVersionEnabled TLS13 params && versionForced < TLS13) - || (isVersionEnabled TLS12 params && versionForced < TLS12) - if downgraded - then runTLSFailure params handshake handshake - else runTLSSimple params - -handshake_update_key :: (ClientParams, ServerParams) -> IO () -handshake_update_key = runTLSSimpleKeyUpdate - --------------------------------------------------------------- - -handshake_hashsignatures - :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () -handshake_hashsignatures (clientHashSigs, serverHashSigs) = do - tls13 <- generate arbitrary - let version = if tls13 then TLS13 else TLS12 - ciphers = - [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 - , cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 - , cipher13_AES_128_GCM_SHA256 - ] - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (ciphers, ciphers) - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedHashSignatures = clientHashSigs - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedHashSignatures = serverHashSigs - } - } - commonHashSigs = clientHashSigs `intersect` serverHashSigs - shouldFail - | tls13 = all incompatibleWithDefaultCurve commonHashSigs - | otherwise = null commonHashSigs - if shouldFail - then runTLSFailure (clientParam', serverParam') handshake handshake - else runTLSSimple (clientParam', serverParam') - where - incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 - incompatibleWithDefaultCurve _ = False - -handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO () -handshake_ciphersuites (clientCiphers, serverCiphers) = do - tls13 <- generate arbitrary - let version = if tls13 then TLS13 else TLS12 - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (clientCiphers, serverCiphers) - let adequate = cipherAllowedForVersion version - shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) - if shouldSucceed - then runTLSSimple (clientParam, serverParam) - else runTLSFailure (clientParam, serverParam) handshake handshake - --------------------------------------------------------------- - -handshake_groups :: GGP -> IO () -handshake_groups (GGP clientGroups serverGroups) = do - tls13 <- generate arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = ciphersuite_strong - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - denyCustom <- generate arbitrary - let groupUsage = - if denyCustom - then GroupUsageUnsupported "custom group denied" - else GroupUsageValid - clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedGroups = clientGroups - } - , clientHooks = - (clientHooks clientParam) - { onCustomFFDHEGroup = \_ _ -> return groupUsage - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedGroups = serverGroups - } - } - commonGroups = clientGroups `intersect` serverGroups - shouldFail = null commonGroups - p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups - if shouldFail - then runTLSFailure (clientParam', serverParam') handshake handshake - else runTLSPredicate (clientParam', serverParam') p - --------------------------------------------------------------- - -newtype SG = SG [Group] deriving (Show) - -instance Arbitrary SG where - arbitrary = SG <$> shuffle sigGroups - where - sigGroups = [P256, P521] - -handshake_ec :: SG -> IO () -handshake_ec (SG sigGroups) = do - let versions = [TLS12] - ciphers = - [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 - ] - hashSignatures = - [ (HashSHA256, SignatureECDSA) - ] - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - clientGroups <- generate $ shuffle sigGroups - clientHashSignatures <- generate $ sublistOf hashSignatures - serverHashSignatures <- generate $ sublistOf hashSignatures - credentials <- generate arbitraryCredentialsOfEachCurve - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedGroups = clientGroups - , supportedHashSignatures = clientHashSignatures - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedGroups = sigGroups - , supportedHashSignatures = serverHashSignatures - } - , serverShared = - (serverShared serverParam) - { sharedCredentials = Credentials credentials - } - } - sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) - ecdsaDenied = SignatureECDSA `notElem` sigAlgs - if ecdsaDenied - then runTLSFailure (clientParam', serverParam') handshake handshake - else runTLSSimple (clientParam', serverParam') - --- Tests ability to use or ignore client "signature_algorithms" extension when --- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but --- the server RSA certificate has a SHA-1 signature that the client does not --- support. Server may choose the DSA certificate only when cipher --- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA --- certificate. - -data OC = OC [Cipher] [Cipher] deriving (Show) - -instance Arbitrary OC where - arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers - where - otherCiphers = - [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 - , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 - ] - -handshake_cert_fallback_cipher :: OC -> IO () -handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do - let clientVersions = [TLS12] - serverVersions = [TLS12] - commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] - hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] - chainRef <- newIORef Nothing - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - (clientVersions, serverVersions) - (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedHashSignatures = hashSignatures - } - , clientHooks = - (clientHooks clientParam) - { onServerCertificate = \_ _ _ chain -> - writeIORef chainRef (Just chain) >> return [] - } - } - runTLSSimple (clientParam', serverParam) - serverChain <- readIORef chainRef - isLeafRSA serverChain `shouldBe` True - --- Same as above but testing with supportedHashSignatures directly instead of --- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the --- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by --- both client and server, the Ed25519 certificate is selected. Otherwise the --- server fallbacks to RSA. --- --- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 --- unless client advertises explicit support. Currently this is not enforced by --- the library, which is useful to test this scenario. SHA-1 could be replaced --- by another algorithm. - -data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm] - deriving (Show) - -instance Arbitrary OHS where - arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS - where - otherHS = [(HashIntrinsic, SignatureEd25519)] - -handshake_cert_fallback_hs :: OHS -> IO () -handshake_cert_fallback_hs (OHS clientHS serverHS) = do - tls13 <- generate arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = - [ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 - , cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 - , cipher13_AES_128_GCM_SHA256 - ] - commonHS = - [ (HashSHA256, SignatureRSA) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) - ] - chainRef <- newIORef Nothing - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedHashSignatures = commonHS ++ clientHS - } - , clientHooks = - (clientHooks clientParam) - { onServerCertificate = \_ _ _ chain -> - writeIORef chainRef (Just chain) >> return [] - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedHashSignatures = commonHS ++ serverHS - } - } - eddsaDisallowed = - (HashIntrinsic, SignatureEd25519) `notElem` clientHS - || (HashIntrinsic, SignatureEd25519) `notElem` serverHS - runTLSSimple (clientParam', serverParam') - serverChain <- readIORef chainRef - isLeafRSA serverChain `shouldBe` eddsaDisallowed - --------------------------------------------------------------- - -handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO () -handshake_server_key_usage usageFlags = do - tls13 <- generate arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = ciphersuite_all - (clientParam, serverParam) <- - generate $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - cred <- generate $ arbitraryRSACredentialWithUsage usageFlags - let serverParam' = - serverParam - { serverShared = - (serverShared serverParam) - { sharedCredentials = Credentials [cred] - } - } - shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags - if shouldSucceed - then runTLSSimple (clientParam, serverParam') - else runTLSFailure (clientParam, serverParam') handshake handshake - -handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO () -handshake_client_key_usage usageFlags = do - (clientParam, serverParam) <- generate arbitrary - cred <- generate $ arbitraryRSACredentialWithUsage usageFlags - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverWantClientCert = True - , serverHooks = - (serverHooks serverParam) - { onClientCertificate = \_ -> return CertificateUsageAccept - } - } - shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags - if shouldSucceed - then runTLSSimple (clientParam', serverParam') - else runTLSFailure (clientParam', serverParam') handshake handshake - --------------------------------------------------------------- - -handshake_client_auth :: (ClientParams, ServerParams) -> IO () -handshake_client_auth (clientParam, serverParam) = do - let clientVersions = supportedVersions $ clientSupported clientParam - serverVersions = supportedVersions $ serverSupported serverParam - version = maximum (clientVersions `intersect` serverVersions) - cred <- generate (arbitraryClientCredential version) - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverWantClientCert = True - , serverHooks = - (serverHooks serverParam) - { onClientCertificate = validateChain cred - } - } - runTLSSimple (clientParam', serverParam') - where - validateChain cred chain - | chain == fst cred = return CertificateUsageAccept - | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) - -handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO () -handshake_client_auth_fail (clientParam, serverParam) = do - let clientVersions = supportedVersions $ clientSupported clientParam - serverVersions = supportedVersions $ serverSupported serverParam - version = maximum (clientVersions `intersect` serverVersions) - cred <- generate (arbitraryClientCredential version) - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverWantClientCert = True - , serverHooks = - (serverHooks serverParam) - { onClientCertificate = validateChain cred - } - } - runTLSFailure (clientParam', serverParam') handshake handshake - where - validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA) - --------------------------------------------------------------- - -handshake_ems :: (EMSMode, EMSMode) -> IO () -handshake_ems (cems, sems) = do - params <- generate arbitrary - let params' = setEMSMode (cems, sems) params - version = getConnectVersion params' - emsVersion = version >= TLS10 && version <= TLS12 - use = cems /= NoEMS && sems /= NoEMS - require = cems == RequireEMS || sems == RequireEMS - p info = infoExtendedMainSecret info == (emsVersion && use) - if emsVersion && require && not use - then runTLSFailure params' handshake handshake - else runTLSPredicate params' (maybe False p) - -newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show) - -instance Arbitrary CompatEMS where - arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible) - where - compatible (NoEMS, RequireEMS) = False - compatible (RequireEMS, NoEMS) = False - compatible _ = True - -handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO () -handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - plainParams <- generate arbitrary - let params = - setEMSMode ems $ - setPairParamsSessionManagers sessionManagers plainParams - - runTLSSimple params - - -- and resume - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - let params2 = - setEMSMode ems2 $ - setPairParamsSessionResuming (fromJust sessionParams) params - - let version = getConnectVersion params2 - emsVersion = version >= TLS10 && version <= TLS12 - - if emsVersion && use ems && not (use ems2) - then runTLSFailure params2 handshake handshake - else do - runTLSSimple params2 - mSessionParams2 <- readClientSessionRef sessionRefs - let sameSession = sessionParams == mSessionParams2 - sameUse = use ems == use ems2 - when emsVersion (sameSession `shouldBe` sameUse) - where - use (NoEMS, _) = False - use (_, NoEMS) = False - use _ = True - --------------------------------------------------------------- - -handshake_alpn :: (ClientParams, ServerParams) -> IO () -handshake_alpn (clientParam, serverParam) = do - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onSuggestALPN = return $ Just ["h2", "http/1.1"] - } - } - serverParam' = - serverParam - { serverHooks = - (serverHooks serverParam) - { onALPNClientSuggest = Just alpn - } - } - params' = (clientParam', serverParam') - runTLSSuccess params' hsClient hsServer - where - hsClient ctx = do - handshake ctx - proto <- getNegotiatedProtocol ctx - proto `shouldBe` Just "h2" - hsServer ctx = do - handshake ctx - proto <- getNegotiatedProtocol ctx - proto `shouldBe` Just "h2" - alpn xs - | "h2" `elem` xs = return "h2" - | otherwise = return "http/1.1" - -handshake_sni :: (ClientParams, ServerParams) -> IO () -handshake_sni (clientParam, serverParam) = do - ref <- newIORef Nothing - let clientParam' = - clientParam - { clientServerIdentification = (serverName, "") - } - serverParam' = - serverParam - { serverHooks = - (serverHooks serverParam) - { onServerNameIndication = onSNI ref - } - } - params' = (clientParam', serverParam') - runTLSSuccess params' hsClient hsServer - receivedName <- readIORef ref - receivedName `shouldBe` Just (Just serverName) - where - hsClient ctx = do - handshake ctx - msni <- getClientSNI ctx - expectMaybe "C: SNI should be Just" serverName msni - hsServer ctx = do - handshake ctx - msni <- getClientSNI ctx - expectMaybe "S: SNI should be Just" serverName msni - onSNI ref name = do - mx <- readIORef ref - mx `shouldBe` Nothing - writeIORef ref (Just name) - return (Credentials []) - serverName = "haskell.org" - --------------------------------------------------------------- - -newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show) - -instance Arbitrary CSP12 where - arbitrary = CSP12 <$> arbitraryPairParams12 - -handshake12_renegotiation :: CSP12 -> IO () -handshake12_renegotiation (CSP12 (cparams, sparams)) = do - renegDisabled <- generate arbitrary - let sparams' = - sparams - { serverSupported = - (serverSupported sparams) - { supportedClientInitiatedRenegotiation = not renegDisabled - } - } - if renegDisabled - then runTLSFailure (cparams, sparams') hsClient hsServer - else runTLSSimple (cparams, sparams') - where - hsClient ctx = handshake ctx >> handshake ctx - -- recvData receives the alert from the second handshake - hsServer ctx = handshake ctx >> void (recvData ctx) - -handshake12_session_resumption :: CSP12 -> IO () -handshake12_session_resumption (CSP12 plainParams) = do - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers plainParams - - runTLSSimple params - - -- and resume - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSPredicate params2 (maybe False infoTLS12Resumption) - -handshake12_session_ticket :: CSP12 -> IO () -handshake12_session_ticket (CSP12 plainParams) = do - sessionRefs <- twoSessionRefs - let sessionManagers0 = twoSessionManagers sessionRefs - sessionManagers = (fst sessionManagers0, oneSessionTicket) - - let params = setPairParamsSessionManagers sessionManagers plainParams - - runTLSSimple params - - -- and resume - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSPredicate params2 (maybe False infoTLS12Resumption) - --------------------------------------------------------------- - -handshake13_full :: CSP13 -> IO () -handshake13_full (CSP13 (cli, srv)) = do - let cliSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - runTLSSimple13 params FullHandshake - -handshake13_hrr :: CSP13 -> IO () -handshake13_hrr (CSP13 (cli, srv)) = do - let cliSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - runTLSSimple13 params HelloRetryRequest - -handshake13_psk :: CSP13 -> IO () -handshake13_psk (CSP13 (cli, srv)) = do - let cliSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSSimple13 params HelloRetryRequest - - -- and resume - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSSimple13 params2 PreSharedKey - -handshake13_psk_ticket :: CSP13 -> IO () -handshake13_psk_ticket (CSP13 (cli, srv)) = do - let cliSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - - sessionRefs <- twoSessionRefs - let sessionManagers0 = twoSessionManagers sessionRefs - sessionManagers = (fst sessionManagers0, oneSessionTicket) - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSSimple13 params HelloRetryRequest - - -- and resume - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSSimple13 params2 PreSharedKey - -handshake13_psk_fallback :: CSP13 -> IO () -handshake13_psk_fallback (CSP13 (cli, srv)) = do - let cliSupported = - defaultSupported - { supportedCiphers = - [ cipher13_AES_128_GCM_SHA256 - , cipher13_AES_128_CCM_SHA256 - ] - , supportedGroups = [P256, X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSSimple13 params HelloRetryRequest - - -- resumption fails because GCM cipher is not supported anymore, full - -- handshake is not possible because X25519 has been removed, so we are - -- back with P256 after hello retry - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params - srv2' = srv2{serverSupported = svrSupported'} - svrSupported' = - defaultSupported - { supportedCiphers = [cipher13_AES_128_CCM_SHA256] - , supportedGroups = [P256] - } - - runTLSSimple13 (cli2, srv2') HelloRetryRequest - -handshake13_0rtt :: CSP13 -> IO () -handshake13_0rtt (CSP13 (cli, srv)) = do - let cliSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [X25519] - } - cliHooks = - defaultClientHooks - { onSuggestALPN = return $ Just ["h2"] - } - svrHooks = - defaultServerHooks - { onALPNClientSuggest = Just (return . unsafeHead) - } - params0 = - ( cli - { clientSupported = cliSupported - , clientHooks = cliHooks - } - , srv - { serverSupported = svrSupported - , serverHooks = svrHooks - , serverEarlyDataSize = 2048 - } - ) - - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSSimple13 params HelloRetryRequest - runTLS0rtt params sessionRefs - runTLS0rtt params sessionRefs - where - runTLS0rtt params sessionRefs = do - -- and resume - sessionParams <- readClientSessionRef sessionRefs - expectJust "session param should be Just" sessionParams - clearClientSessionRef sessionRefs - earlyData <- B.pack <$> generate (someWords8 256) - let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params - params2 = (pc{clientUseEarlyData = True}, ps) - - runTLS0RTT params2 RTT0 earlyData - -handshake13_0rtt_fallback :: CSP13 -> IO () -handshake13_0rtt_fallback (CSP13 (cli, srv)) = do - group0 <- generate $ elements [P256, X25519] - let cliSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [group0] - } - params = - ( cli{clientSupported = cliSupported} - , srv - { serverSupported = svrSupported - , serverEarlyDataSize = 1024 - } - ) - - sessionRefs <- twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params0 = setPairParamsSessionManagers sessionManagers params - - let mode = if group0 == P256 then FullHandshake else HelloRetryRequest - runTLSSimple13 params0 mode - - -- and resume - mSessionParams <- readClientSessionRef sessionRefs - case mSessionParams of - Nothing -> expectationFailure "session params: Just is expected" - Just sessionParams -> do - earlyData <- B.pack <$> generate (someWords8 256) - group1 <- generate $ elements [P256, X25519] - let (pc, ps) = setPairParamsSessionResuming sessionParams params0 - svrSupported1 = - defaultSupported - { supportedCiphers = [cipher13_AES_128_GCM_SHA256] - , supportedGroups = [group1] - } - params1 = - ( pc{clientUseEarlyData = True} - , ps - { serverEarlyDataSize = 0 - , serverSupported = svrSupported1 - } - ) - -- C: [P256, X25519] - -- S: [group0] - -- C: [P256, X25519] - -- S: [group1] - if group0 == group1 - -- 0-RTT is not allowed, so fallback to PreSharedKey - then runTLS0RTT params1 PreSharedKey earlyData - -- HRR but not allowed for 0-RTT - else runTLSFailure params1 (tlsClient earlyData) tlsServer - where - tlsClient earlyData ctx = do - handshake ctx - sendData ctx $ L.fromStrict earlyData - _ <- recvData ctx - bye ctx - tlsServer ctx = do - handshake ctx - _ <- recvData ctx - bye ctx - -handshake13_ee_groups :: CSP13 -> IO () -handshake13_ee_groups (CSP13 (cli, srv)) = do - let -- The client prefers P256 - cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} - -- The server prefers X25519 - svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]} - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - (_, serverMessages) <- runTLSCapture13 params - -- The server should tell X25519 in supported_groups in EE to clinet - let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups - eeMessagesHaveExt = - [ any isSupportedGroups exts - | EncryptedExtensions13 exts <- serverMessages - ] - eeMessagesHaveExt `shouldBe` [True] - -handshake13_ec :: CSP13 -> IO () -handshake13_ec (CSP13 (cli, srv)) = do - EC cgrps <- generate arbitrary - EC sgrps <- generate arbitrary - let cliSupported = (clientSupported cli){supportedGroups = cgrps} - svrSupported = (serverSupported srv){supportedGroups = sgrps} - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - runTLSSimple13 params FullHandshake - -handshake13_ffdhe :: CSP13 -> IO () -handshake13_ffdhe (CSP13 (cli, srv)) = do - FFDHE cgrps <- generate arbitrary - FFDHE sgrps <- generate arbitrary - let cliSupported = (clientSupported cli){supportedGroups = cgrps} - svrSupported = (serverSupported srv){supportedGroups = sgrps} - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - runTLSSimple13 params FullHandshake - -post_handshake_auth :: CSP13 -> IO () -post_handshake_auth (CSP13 (clientParam, serverParam)) = do - cred <- generate (arbitraryClientCredential TLS13) - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverHooks = - (serverHooks serverParam) - { onClientCertificate = validateChain cred - } - } - if isCredentialDSA cred - then runTLSFailure (clientParam', serverParam') hsClient hsServer - else runTLSSuccess (clientParam', serverParam') hsClient hsServer - where - validateChain cred chain - | chain == fst cred = return CertificateUsageAccept - | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) - hsClient ctx = do - handshake ctx - sendData ctx "request 1" - recvDataAssert ctx "response 1" - sendData ctx "request 2" - recvDataAssert ctx "response 2" - hsServer ctx = do - handshake ctx - recvDataAssert ctx "request 1" - _ <- requestCertificate ctx -- single request - sendData ctx "response 1" - recvDataAssert ctx "request 2" - _ <- requestCertificate ctx - _ <- requestCertificate ctx -- two simultaneously - sendData ctx "response 2" +import Control.Concurrent ( + MVar, + forkIO, + newEmptyMVar, + putMVar, + takeMVar, + threadDelay, + ) +import Control.Concurrent.Async (concurrently_) +import qualified Control.Exception as E +import Control.Monad +import Crypto.Cipher.AES (AES128) +import Crypto.Cipher.Types (AEADMode (..), AuthTag (..), aeadInit, aeadSimpleEncrypt, cipherInit) +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 +import qualified Data.ByteString.Lazy as L +import Data.IORef +import Data.List +import Data.Maybe +import Data.Word (Word16, Word64, Word8) +import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) +import Data.X509.Validation (FailedReason (..)) +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 +import Test.Hspec.QuickCheck +import System.Timeout (timeout) +import Test.QuickCheck + +import API +import Arbitrary +import Certificate (arbitraryRSACredentialWithPurpose, arbitraryX509WithKey) +import PipeChan +import PubKey (rsaParams) +import Run +import Session + +spec :: Spec +spec = do + describe "pipe" $ do + it "can setup a channel" pipe_work + describe "channel binding" $ do + prop "is unavailable before the handshake" binding_before_handshake + describe "handshake" $ do + prop "can run TLS 1.2" handshake_simple + prop "can run TLS 1.3" handshake13_simple + prop "can update key for TLS 1.3" handshake_update_key + prop "tells close_notify from an EOF" $ handshake_close_notify True + prop "tells an EOF without close_notify" $ handshake_close_notify False + it + "rejects more than 32 consecutive TLS 1.3 KeyUpdates" + handshake_key_update_flood + it + "can disable the consecutive TLS 1.3 KeyUpdate limit" + handshake_key_update_unlimited + it + "does not disable TLS 1.3 KeyUpdates with non-positive limits" + handshake_key_update_non_positive + prop "can prevent downgrade attack" handshake13_downgrade + it "negotiates TLS 1.2 with a ClientHello naming a higher version" $ + handshake_high_legacy_version TLS12 (Version 0x0309) + it "keeps to the TLS 1.3 server's record size limit" $ + record_size_limit_negotiated TLS13 False + it "keeps to the TLS 1.3 client's record size limit" $ + record_size_limit_negotiated TLS13 True + it "keeps to the TLS 1.2 server's record size limit" $ + record_size_limit_negotiated TLS12 False + it "keeps to the TLS 1.2 client's record size limit" $ + record_size_limit_negotiated TLS12 True + it "ignores the client's record size limit the TLS 1.3 server does not take" $ + record_size_limit_unnegotiated TLS13 True + it "ignores the server's record size limit the TLS 1.3 client did not offer" $ + record_size_limit_unnegotiated TLS13 False + it "ignores the client's record size limit the TLS 1.2 server does not take" $ + record_size_limit_unnegotiated TLS12 True + it "ignores the server's record size limit the TLS 1.2 client did not offer" $ + record_size_limit_unnegotiated TLS12 False + it "rejects ec_point_formats without uncompressed" $ + handshake12_ec_point_formats + (B.pack [1, 1]) + rejectedAsIllegalParameter + it "rejects an empty ec_point_formats" $ + handshake12_ec_point_formats (B.pack [0]) rejectedAsDecodeError + prop "can negotiate hash and signature" handshake_hashsignatures + prop "can negotiate cipher suite" handshake_ciphersuites + it "rejects a cipher outside the server callback candidates" $ + handshake_rejects_server_cipher_callback_escape + it "rejects a TLS 1.2-only cipher selected for TLS 1.3" $ + handshake_rejects_legacy_cipher_in_tls13 + prop "can negotiate group" handshake_groups + prop "can negotiate elliptic curve" handshake_ec + prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher + prop + "can fallback for certificate with hash and signature" + handshake_cert_fallback_hs + prop "can handle server key usage" handshake_server_key_usage + it "accepts a TLS 1.2 server certificate permitting server auth" $ + handshake_server_key_purpose TLS12 KeyUsagePurpose_ServerAuth True + it "accepts a TLS 1.3 server certificate permitting server auth" $ + handshake_server_key_purpose TLS13 KeyUsagePurpose_ServerAuth True + it "rejects a TLS 1.2 server certificate restricted to client auth" $ + handshake_server_key_purpose TLS12 KeyUsagePurpose_ClientAuth False + 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 + it "rejects a primitive SEQUENCE as an ECDSA signature" $ + handshake13_client_cert_verify_malformed_ecdsa $ \sig -> + B.cons (B.head sig `xor` 0x20) (B.tail sig) + it "rejects a BIT STRING in an ECDSA signature" $ + handshake13_client_cert_verify_malformed_ecdsa $ \_ -> + B.pack [0x30, 0x06, 0x02, 0x01, 0x01, 0x03, 0x01, 0x09] + it "rejects a TLS 1.2 CertificateVerify algorithm for another key type" $ + handshake12_client_cert_verify_sigalg + ECDSA_SECP256R1_SHA256 + rejectedAsIllegalParameter + it "rejects a TLS 1.2 CertificateVerify that does not fit the RSA key" $ + handshake12_client_cert_verify_sigalg + RSA_PSS_PSS_SHA256 + rejectedAsDecryptError + it "rejects a TLS 1.2 ServerKeyExchange algorithm for another key type" $ + handshake12_server_key_xchg_sigalg + ECDSA_SECP256R1_SHA256 + rejectedAsIllegalParameter + it "rejects a TLS 1.2 ServerKeyExchange that does not fit the RSA key" $ + handshake12_server_key_xchg_sigalg + 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 + it "accepts an empty TLS 1.3 client certificate when the hook does" $ + handshake_client_auth_empty TLS13 + it "rejects a TLS 1.2 client omitting the requested certificate" $ + handshake12_client_cert_omitted + it "rejects a TLS 1.2 server omitting Certificate" $ + handshake12_server_message_omitted 11 + it "answers a corrupt certificate with bad_certificate" $ + handshake12_corrupt_certificate False + it "answers an empty certificate with decode_error" $ + handshake12_corrupt_certificate True + it "rejects a TLS 1.2 server omitting ServerKeyExchange for ECDHE" $ + handshake12_server_message_omitted 12 + it "requests only defined certificate types in TLS 1.2" $ + handshake12_cert_request_types + prop "can handle extended main secret" handshake_ems + prop "can resume with extended main secret" handshake_resumption_ems + prop "can handle ALPN" handshake_alpn + it "rejects an unoffered ALPN selection from the server hook" $ + handshake_alpn_rejects_unoffered_server_selection + it "rejects an unoffered ALPN selection received by the client" $ + handshake_alpn_rejects_unoffered_client_selection + prop "can handle SNI" handshake_sni + it "sends no SNI for an empty server name" handshake_sni_empty + it "rejects multiple host_names in SNI" $ + handshake_sni_illegal ["example.com", "example.org"] + it "rejects a host_name with a control character in SNI" $ + handshake_sni_illegal ["example\0.com"] + it "rejects a non-ASCII host_name in SNI" $ + handshake_sni_illegal ["ex\xc4\x85mple.com"] + prop "can handshake with TLS 1.2 CBC" handshake_cbc + prop "can re-negotiate with TLS 1.2" handshake12_renegotiation + it "keeps application data that arrives during a TLS 1.2 renegotiation" $ + handshake12_renegotiation_interleaved + it "ignores HelloRequest during a TLS 1.2 handshake" $ + handshake12_hello_request_ignored + it "rejects SCSV in a secure renegotiation" $ + handshake12_renegotiation_tampered $ \ch -> + ch{chCiphers = chCiphers ch ++ [CipherId 0xff]} + it "rejects a secure renegotiation without renegotiation_info" $ + handshake12_renegotiation_tampered $ \ch -> + ch + { chExtensions = + filter + (\(ExtensionRaw eid _) -> eid /= EID_SecureRenegotiation) + (chExtensions ch) + } + prop "can resume session with TLS 1.2" handshake12_session_resumption + prop + "rejects resuming a TLS 1.2 session without its cipher" + handshake12_session_resumption_cipher_missing + prop "can resume session ticket with TLS 1.2" handshake12_session_ticket + it "sends no session ticket to a TLS 1.2 client that did not ask" $ + handshake12_session_ticket_unoffered + prop "can handshake with TLS 1.3 Full" handshake13_full + prop "can handshake with TLS 1.3 HRR" handshake13_hrr + prop "can handshake with TLS 1.3 PSK" handshake13_psk + it "does not resume a TLS 1.2 session with a TLS 1.3 PSK" $ + handshake13_psk_tls12_session + prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket + prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback + it "binds the PSK to the transcript after HRR" handshake13_psk_hrr_binder + prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt + it "rejects TLS 1.3 early data when ALPN changes" $ + handshake13_0rtt_alpn + prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback + it "keeps the application's data and asks it about 0RTT" $ + handshake13_0rtt_app_data True + it "refuses 0RTT, not the resumption, when the application says so" $ + handshake13_0rtt_app_data False + it "authenticates a server rejecting the PSK of 0RTT" $ + handshake13_0rtt_psk_rejected False + it "authenticates a server rejecting the PSK of 0RTT, asking a cert" $ + handshake13_0rtt_psk_rejected True + it "skips rejected early data in many records" $ + handshake13_0rtt_skip (replicate 5 100) True + it "skips rejected early data beyond serverEarlyDataSize" $ + handshake13_0rtt_skip [10000] True + it "refuses rejected early data over a record's worth" $ + handshake13_0rtt_skip [16384, 4000] False + prop "can handshake with TLS 1.3 EE" handshake13_ee_groups + prop "can handshake with TLS 1.3 EC groups" handshake13_ec + prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe + mapM_ + ( \grp -> + prop ("can handshake with " ++ show grp) $ + handshake13_kem grp + ) + [ MLKEM512 + , MLKEM768 + , MLKEM1024 + , X25519MLKEM768 + , P256MLKEM768 + , P384MLKEM1024 + ] + mapM_ + ( \(n, nm) -> do + prop ("can handshake with an " ++ nm ++ " server certificate") $ + handshake13_mldsa n + prop ("can handshake with an " ++ nm ++ " client certificate") $ + handshake13_mldsa_client n + ) + [(0, "ML-DSA-44"), (1, "ML-DSA-65"), (2, "ML-DSA-87")] + it "rejects a CertificateVerify whose scheme is not the key's" $ + handshake13_mldsa_wrong_scheme + it "rejects an X25519MLKEM768 key share with a zero X25519 part" $ + handshake13_x25519mlkem768_zero_x25519 + prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth + 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 + it "rejects a too short TLS 1.2 AEAD record with bad_record_mac" $ + short_record_bad_record_mac TLS12 cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + it "rejects a too short TLS 1.2 CBC record with bad_record_mac" $ + short_record_bad_record_mac TLS12 cipher_ECDHE_RSA_AES128CBC_SHA256 + it "rejects a too short TLS 1.3 record with bad_record_mac" $ + short_record_bad_record_mac TLS13 cipher13_AES_128_GCM_SHA256 + it "rejects a TLS 1.3 alert in clear after the handshake" $ + plaintext_alert13_rejected + it "rejects a TLS 1.2 ChangeCipherSpec before the keys" $ + early_ccs12_rejected + it "rejects a ServerHello as the first client message" $ + server_first_message_unexpected 2 + it "rejects a Finished as the first client message" $ + server_first_message_unexpected 20 + it "rejects an unknown handshake type as the first client message" $ + server_first_message_unexpected 254 + it "rejects a ChangeCipherSpec before the first ClientHello" $ + server_ccs_interleaved 0 + it "rejects a ChangeCipherSpec inside a fragmented ClientHello" $ + server_ccs_interleaved 2 + it "rejects an SSLv2-style record header at once" $ + server_first_record_type_unexpected 0x80 0x3fff + it "rejects an unknown record type" $ + server_first_record_type_unexpected 24 0 + it "rejects application data inside a TLS 1.3 handshake message" $ + handshake13_interleaved_app_data + it "rejects an unexpected handshake message after the handshake" $ + handshake13_unexpected_post_handshake + it "treats a warning-level error alert as an error" $ + handshake13_warning_error_alert + it "treats a fatal-level close_notify as a closure" $ + handshake13_fatal_close_notify + it "rejects a protected change_cipher_spec in the handshake" $ + handshake13_protected_ccs + it "rejects an empty handshake record before a ClientHello" $ + handshake_empty_handshake_record True + it "rejects an empty handshake record inside a ClientHello" $ + handshake_empty_handshake_record False + it "accepts a TLS 1.2 ClientHello in one-byte records" $ + handshake_one_byte_records TLS12 Nothing + it "accepts a TLS 1.3 ClientHello in one-byte records" $ + handshake_one_byte_records TLS13 Nothing + it "rejects a ClientHello in more records than the limit" $ + handshake_one_byte_records TLS13 (Just 8) + it "rejects a message after ClientHello in its record" $ + handshake13_trailing_after_hello True + it "rejects a message after ServerHello in its record" $ + handshake13_trailing_after_hello False + it "rejects a message after ServerHello in its record with 0-RTT" $ + handshake13_0rtt_trailing_after_server_hello + it "rejects a message after KeyUpdate in its record" $ + handshake13_trailing_after_key_update + prop "offers a PSK for the same SNI" $ handshake13_psk_sni True + prop "does not offer a PSK for another SNI" $ handshake13_psk_sni False + it "resumes with the second PSK when the first is unknown" $ + handshake13_second_psk + it "keeps the key shares for a HelloRetryRequest with only a cookie" $ + handshake13_hrr_without_key_share True + it "rejects a HelloRetryRequest that changes nothing" $ + handshake13_hrr_without_key_share False + it "rejects a second ClientHello with another random" $ + handshake13_hrr_second_hello otherRandom (Just "changed") + it "rejects a second ClientHello with an extension added" $ + handshake13_hrr_second_hello extensionAdded (Just "changed") + it "rejects a second ClientHello with the first key_share" $ + handshake13_hrr_second_hello firstKeyShare (Just "key_share") + it "accepts a second ClientHello with extensions reordered" $ + handshake13_hrr_second_hello reordered Nothing + it "rejects a legacy_version above TLS 1.2 with supported_versions" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + serverRefusesHello + params + (\ch -> ch{chVersion = TLS13}) + (refusedWith ProtocolVersion) + it "rejects supported_versions without TLS 1.2 in a TLS 1.2 server" $ do + (cli, srv) <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let cli' = cli{clientSupported = (clientSupported cli){supportedVersions = [TLS13]}} + srv' = srv{serverSupported = (serverSupported srv){supportedVersions = [TLS12]}} + serverRefusesHello (cli', srv') id (refusedWith ProtocolVersion) + it "rejects a ServerHello legacy_version other than TLS 1.2" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + clientRefusesHello + params + (\sh -> sh{shVersion = TLS13}) + (refusedWith ProtocolVersion) + it "rejects supported_versions in a ServerHello choosing TLS 1.2" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let tls12 (ExtensionRaw EID_SupportedVersions _) = + toExtensionRaw $ SupportedVersionsServerHello TLS12 + tls12 e = e + clientRefusesHello + params + (\sh -> sh{shExtensions = map tls12 $ shExtensions sh}) + (refusedFor IllegalParameter "supported_versions") + it "rejects a TLS 1.2 ServerHello in a TLS 1.3 client" $ do + (cli, srv) <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let cli' = cli{clientSupported = (clientSupported cli){supportedVersions = [TLS13]}} + noVersions (ExtensionRaw eid _) = eid /= EID_SupportedVersions + clientRefusesHello + (cli', srv) + (\sh -> sh{shExtensions = filter noVersions $ shExtensions sh}) + (refusedWith ProtocolVersion) + it "rejects ALPN in a TLS 1.3 ServerHello" $ do + (cli, srv) <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let cli' = cli{clientHooks = (clientHooks cli){onSuggestALPN = return $ Just ["h2"]}} + alpn = toExtensionRaw $ ApplicationLayerProtocolNegotiation ["h2"] + clientRefusesHello + (cli', srv) + (\sh -> sh{shExtensions = shExtensions sh ++ [alpn]}) + (refusedWith IllegalParameter) + it "rejects supported_versions in EncryptedExtensions" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let versions = toExtensionRaw $ SupportedVersionsServerHello TLS13 + tamper (EncryptedExtensions13 exts) = + pure $ EncryptedExtensions13 $ exts ++ [versions] + tamper h = pure h + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv cctx tamper + concurrently_ + (handshake sctx `shouldThrow` anyTLSException) + (handshake cctx `shouldThrow` refusedWith IllegalParameter) + it "rejects a TLS 1.3 ClientHello without signature_algorithms" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + serverRefusesHello + params + (withoutExt EID_SignatureAlgorithms) + (refusedWith MissingExtension) + it "rejects a TLS 1.3 ClientHello with key_share but no supported_groups" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + serverRefusesHello + params + (withoutExt EID_SupportedGroups) + (refusedWith MissingExtension) + it "rejects a key_share for a group not in supported_groups" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let p256 (ExtensionRaw EID_SupportedGroups _) = toExtensionRaw $ SupportedGroups [P256] + p256 e = e + serverRefusesHello + params + (\ch -> ch{chExtensions = map p256 $ chExtensions ch}) + (refusedWith IllegalParameter) + it "rejects data after the content of supported_groups" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let trailing (ExtensionRaw EID_SupportedGroups bs) = + ExtensionRaw EID_SupportedGroups $ B.snoc bs 0 + trailing e = e + serverRefusesHello + 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 + cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + [P256] + [P256] + it "rejects a two-byte TLS 1.3 ChangeCipherSpec" $ + malformed_ccs_unexpected TLS13 cipher13_AES_128_GCM_SHA256 [X25519] [X25519] + it "rejects a two-byte TLS 1.3 ChangeCipherSpec after HelloRetryRequest" $ + malformed_ccs_unexpected + TLS13 + cipher13_AES_128_GCM_SHA256 + [P256, X25519] + [X25519] + +-------------------------------------------------------------- + +-- | Both channel bindings already answer with 'Maybe', and a caller may +-- reasonably ask for one on a context whose handshake has not run -- or has +-- failed. The answer is that there is no binding, not a crash. +binding_before_handshake :: (ClientParams, ServerParams) -> IO () +binding_before_handshake params = withPairContext params $ \(cCtx, sCtx) -> + forM_ [cCtx, sCtx] $ \ctx -> do + getTLSUnique ctx `shouldReturn` Nothing + getTLSExporter ctx `shouldReturn` Nothing + +pipe_work :: IO () +pipe_work = do + pipe <- newPipe + _ <- runPipe pipe + + let bSize = 16 + n <- generate (choose (1, 32)) + + let d1 = B.replicate (bSize * n) 40 + let d2 = B.replicate (bSize * n) 45 + + d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1) + d1' `shouldBe` d1 + + d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2) + d2' `shouldBe` d2 + +-------------------------------------------------------------- + +handshake_simple :: (ClientParams, ServerParams) -> IO () +handshake_simple = runTLSSimple + +-------------------------------------------------------------- + +newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP13 where + arbitrary = CSP13 <$> arbitraryPairParams13 + +handshake13_simple :: CSP13 -> IO () +handshake13_simple (CSP13 params) = runTLSSimple13 params hs + where + cgrps = supportedGroups $ clientSupported $ fst params + sgrps = supportedGroups $ serverSupported $ snd params + hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest + +handshake_rejects_server_cipher_callback_escape :: IO () +handshake_rejects_server_cipher_callback_escape = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + let params = cipherSelectionParams clientParam serverParam selectLegacy + withPairContextWith (id, id) params $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` serverRejectedCipherEscape) + (handshake cctx `shouldThrow` anyTLSException) + where + selectLegacy _ _ = cipher_ECDHE_RSA_AES128CBC_SHA256 + +handshake_rejects_legacy_cipher_in_tls13 :: IO () +handshake_rejects_legacy_cipher_in_tls13 = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + let params = cipherSelectionParams clientParam serverParam defaultSelection + withPairContextWith (id, id) params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv cctx tamperCipher + concurrently_ + (handshake sctx `shouldThrow` anyTLSException) + (handshake cctx `shouldThrow` clientRejectedLegacyCipher) + where + defaultSelection _ = unsafeHead + tamperCipher (ServerHello sh) = + pure $ + ServerHello + sh + { shCipher = + CipherId $ cipherID cipher_ECDHE_RSA_AES128CBC_SHA256 + } + tamperCipher hs = pure hs + +cipherSelectionParams + :: ClientParams + -> ServerParams + -> (Version -> [Cipher] -> Cipher) + -> (ClientParams, ServerParams) +cipherSelectionParams clientParam serverParam select = + ( clientParam{clientSupported = supported} + , serverParam + { serverSupported = supported + , serverHooks = + (serverHooks serverParam) + { onCipherChoosing = select + } + } + ) + where + supported = + defaultSupported + { supportedVersions = [TLS13] + , supportedCiphers = + [ cipher13_AES_128_GCM_SHA256 + , cipher_ECDHE_RSA_AES128CBC_SHA256 + ] + } + +serverRejectedCipherEscape :: TLSException -> Bool +serverRejectedCipherEscape (HandshakeFailed (Error_Protocol msg alert)) = + msg == "onCipherChoosing selected a cipher outside the candidate list" + && alert == InternalError +serverRejectedCipherEscape _ = False + +clientRejectedLegacyCipher :: TLSException -> Bool +clientRejectedLegacyCipher (HandshakeFailed (Error_Protocol msg alert)) = + msg == "server selected a cipher invalid for the negotiated version" + && alert == IllegalParameter +clientRejectedLegacyCipher _ = False + +anyTLSException :: TLSException -> Bool +anyTLSException = const True + +handshake_key_update_flood :: IO () +handshake_key_update_flood = do + params <- generate arbitraryPairParams13 + withPairContextWith (id, id) params $ \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + recvData sctx `shouldReturn` "after 32 key updates" + recvData sctx `shouldThrow` excessiveKeyUpdate + ) + ( do + handshake cctx + replicateM_ 32 $ void $ updateKey cctx OneWay + sendData cctx "after 32 key updates" + replicateM_ 33 $ void $ updateKey cctx OneWay + sendData cctx "after 33 key updates" + ) + where + excessiveKeyUpdate + (Terminated _ _ (Error_Misc "too many consecutive KeyUpdate messages")) = True + excessiveKeyUpdate _ = False + +handshake_key_update_unlimited :: IO () +handshake_key_update_unlimited = do + (cparams, sparams0) <- generate arbitraryPairParams13 + let shared0 = serverShared sparams0 + limits = (sharedLimit shared0){limitKeyUpdate = Nothing} + sparams = sparams0{serverShared = shared0{sharedLimit = limits}} + withPairContextWith (id, id) (cparams, sparams) $ \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + recvData sctx `shouldReturn` "after 33 key updates" + ) + ( do + handshake cctx + replicateM_ 33 $ void $ updateKey cctx OneWay + sendData cctx "after 33 key updates" + ) + +handshake_key_update_non_positive :: IO () +handshake_key_update_non_positive = + forM_ [0, -1] $ \limit -> do + (cparams, sparams0) <- generate arbitraryPairParams13 + let shared0 = serverShared sparams0 + limits = (sharedLimit shared0){limitKeyUpdate = Just limit} + sparams = sparams0{serverShared = shared0{sharedLimit = limits}} + withPairContextWith (id, id) (cparams, sparams) $ \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + recvData sctx `shouldReturn` "after key update" + ) + ( do + handshake cctx + void $ updateKey cctx OneWay + sendData cctx "after key update" + ) + +-------------------------------------------------------------- + +handshake_cbc :: IO () +handshake_cbc = do + clientCiphers <- generate $ cipherGen >>= shuffle + serverCiphers <- generate $ cipherGen >>= shuffle + clientGroups <- generate $ groupGen >>= shuffle + serverGroups <- generate $ groupGen >>= shuffle + (clientParam, serverParam) <- generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + (clientCiphers, serverCiphers) + let clientParam' = clientParam { + clientSupported = (clientSupported clientParam) + { supportedGroups = clientGroups } } + serverParam' = serverParam { + serverSupported = (serverSupported serverParam) + { supportedGroups = serverGroups } } + let ciphers = clientCiphers `intersect` serverCiphers + groups = clientGroups `intersect` serverGroups + in if compat ciphers groups + then runTLSSimple (clientParam', serverParam') + else runTLSFailure (clientParam', serverParam') handshake handshake + where + groupGen :: Gen [Group] + groupGen = sublistOf grps `suchThat` (not . null) + where + grps = [X25519, P256, P384, FFDHE2048, FFDHE3072, FFDHE4096] + + cipherGen :: Gen [Cipher] + cipherGen = sublistOf ciphersuite_pfs_sha2_cbc `suchThat` (not . null) + + compat :: [Cipher] -> [Group] -> Bool + compat [] _ = False + compat _ [] = False + compat ciphers groups = + let mustdh = all (== CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers + mustec = all (/= CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers + havedh = any (`elem` [FFDHE2048, FFDHE3072, FFDHE4096]) groups + haveec = any (`elem` [X25519, P256, P384]) groups + in ((not mustdh || havedh) && (not mustec || haveec)) + +-------------------------------------------------------------- + +handshake13_downgrade :: (ClientParams, ServerParams) -> IO () +handshake13_downgrade (cparam, sparam) = do + versionForced <- + generate $ elements (supportedVersions $ clientSupported cparam) + let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} + sparam' = sparam{serverDebug = debug'} + params = (cparam, sparam') + downgraded = + (isVersionEnabled TLS13 params && versionForced < TLS13) + || (isVersionEnabled TLS12 params && versionForced < TLS12) + if downgraded + then runTLSFailure params handshake handshake + else runTLSSimple params + +-- RFC 9846 Section 6.1: an EOF without close_notify may be a truncation. +handshake_close_notify :: Bool -> (ClientParams, ServerParams) -> IO () +handshake_close_notify sendBye params = do + closed <- newIORef False + let close be = + be + { backendRecv = \n -> do + c <- readIORef closed + if c then return "" else backendRecv be n + } + withPairContextWith (id, close) params $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + -- The transport is closed before 'recvData' starts to read. + if sendBye + then concurrently_ (bye cctx) $ recvData sctx `shouldReturn` "" + else do + writeIORef closed True + recvData sctx `shouldReturn` "" + closeNotifyReceived sctx `shouldReturn` sendBye + +handshake_update_key :: (ClientParams, ServerParams) -> IO () +handshake_update_key = runTLSSimpleKeyUpdate + +-------------------------------------------------------------- + +handshake_hashsignatures + :: ([SignatureScheme], [SignatureScheme]) -> IO () +handshake_hashsignatures (clientHashSigs, serverHashSigs) = do + tls13 <- generate arbitrary + let version = if tls13 then TLS13 else TLS12 + ciphers = + [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 + , cipher13_AES_128_GCM_SHA256 + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + (ciphers, ciphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = clientHashSigs + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = serverHashSigs + } + } + commonHashSigs = clientHashSigs `intersect` serverHashSigs + shouldFail + | tls13 = all incompatibleWithDefaultCurve commonHashSigs + | otherwise = null commonHashSigs + if shouldFail + then runTLSFailure (clientParam', serverParam') handshake handshake + else runTLSSimple (clientParam', serverParam') + where + -- 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 + tls13 <- generate arbitrary + let version = if tls13 then TLS13 else TLS12 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + (clientCiphers, serverCiphers) + let adequate = cipherAllowedForVersion version + shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) + if shouldSucceed + then runTLSSimple (clientParam, serverParam) + else runTLSFailure (clientParam, serverParam) handshake handshake + +-------------------------------------------------------------- + +handshake_groups :: GGP -> IO () +handshake_groups (GGP clientGroups serverGroups) = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = ciphersuite_strong + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + denyCustom <- generate arbitrary + let groupUsage = + if denyCustom + then GroupUsageUnsupported "custom group denied" + else GroupUsageValid + clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = clientGroups + } + , clientHooks = + (clientHooks clientParam) + { onCustomFFDHEGroup = \_ _ -> return groupUsage + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedGroups = serverGroups + , supportedGroupsTLS13 = [serverGroups] + } + } + commonGroups = clientGroups `intersect` serverGroups + shouldFail = null commonGroups + p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups + if shouldFail + then runTLSFailure (clientParam', serverParam') handshake handshake + else runTLSPredicate (clientParam', serverParam') p + +-------------------------------------------------------------- + +newtype SG = SG [Group] deriving (Show) + +instance Arbitrary SG where + arbitrary = SG <$> shuffle sigGroups + where + sigGroups = [P256, P521] + +handshake_ec :: SG -> IO () +handshake_ec (SG sigGroups) = do + let versions = [TLS12] + ciphers = + [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 + ] + hashSignatures = + [ ECDSA_SECP256R1_SHA256 + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + clientGroups <- generate $ shuffle sigGroups + clientHashSignatures <- generate $ sublistOf hashSignatures + serverHashSignatures <- generate $ sublistOf hashSignatures + credentials <- generate arbitraryCredentialsOfEachCurve + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = clientGroups + , supportedHashSignatures = clientHashSignatures + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedGroups = sigGroups + , supportedGroupsTLS13 = [sigGroups] + , supportedHashSignatures = serverHashSignatures + } + , serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials credentials + } + } + sigAlgs = clientHashSignatures `intersect` serverHashSignatures + ecdsaDenied = not (any (`elem` ecdsaSchemes) sigAlgs) + if ecdsaDenied + then runTLSFailure (clientParam', serverParam') handshake handshake + else runTLSSimple (clientParam', serverParam') + +-- Tests ability to use or ignore client "signature_algorithms" extension when +-- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but +-- the server RSA certificate has a SHA-1 signature that the client does not +-- support. Server may choose the DSA certificate only when cipher +-- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA +-- certificate. + +data OC = OC [Cipher] [Cipher] deriving (Show) + +instance Arbitrary OC where + arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers + where + otherCiphers = + [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + ] + +handshake_cert_fallback_cipher :: OC -> IO () +handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do + let clientVersions = [TLS12] + serverVersions = [TLS12] + commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] + hashSignatures = [RSA_PKCS1_SHA256, DSA_SHA1] + chainRef <- newIORef Nothing + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = hashSignatures + } + , clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] + } + } + runTLSSimple (clientParam', serverParam) + serverChain <- readIORef chainRef + isLeafRSA serverChain `shouldBe` True + +-- Same as above but testing with supportedHashSignatures directly instead of +-- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the +-- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by +-- both client and server, the Ed25519 certificate is selected. Otherwise the +-- server fallbacks to RSA. +-- +-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 +-- unless client advertises explicit support. Currently this is not enforced by +-- the library, which is useful to test this scenario. SHA-1 could be replaced +-- by another algorithm. + +data OHS = OHS [SignatureScheme] [SignatureScheme] + deriving (Show) + +instance Arbitrary OHS where + arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS + where + otherHS = [ED25519] + +handshake_cert_fallback_hs :: OHS -> IO () +handshake_cert_fallback_hs (OHS clientHS serverHS) = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = + [ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + , cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 + , cipher13_AES_128_GCM_SHA256 + ] + commonHS = + [ RSA_PKCS1_SHA256 + , RSA_PSS_RSAE_SHA256 + ] + chainRef <- newIORef Nothing + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = commonHS ++ clientHS + } + , clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = commonHS ++ serverHS + } + } + eddsaDisallowed = + ED25519 `notElem` clientHS + || ED25519 `notElem` serverHS + runTLSSimple (clientParam', serverParam') + serverChain <- readIORef chainRef + isLeafRSA serverChain `shouldBe` eddsaDisallowed + +-------------------------------------------------------------- + +handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_server_key_usage usageFlags = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = ciphersuite_all + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + cred <- generate $ arbitraryRSACredentialWithUsage usageFlags + let serverParam' = + serverParam + { serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials [cred] + } + } + shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags + if shouldSucceed + then runTLSSimple (clientParam, serverParam') + else runTLSFailure (clientParam, serverParam') handshake handshake + +handshake_server_key_purpose :: Version -> ExtKeyUsagePurpose -> Bool -> IO () +handshake_server_key_purpose version purpose shouldSucceed = 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 purpose + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ _ -> return [] + } + } + serverParam' = + serverParam + { serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials [cred] + } + } + if shouldSucceed + then runTLSSimple (clientParam', serverParam') + else runTLSFailure (clientParam', serverParam') handshake handshake + +handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_client_key_usage usageFlags = do + (clientParam, serverParam) <- generate arbitrary + cred <- generate $ arbitraryRSACredentialWithUsage usageFlags + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags + if shouldSucceed + then 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 () +handshake_client_auth (clientParam, serverParam) = do + let clientVersions = supportedVersions $ clientSupported clientParam + serverVersions = supportedVersions $ serverSupported serverParam + version = maximum (clientVersions `intersect` serverVersions) + cred <- generate (arbitraryClientCredential version) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + runTLSSimple (clientParam', serverParam') + where + validateChain cred chain + | chain == fst cred = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + +-- A client without a certificate answers CertificateRequest with an empty +-- Certificate and, in TLS 1.2, sends no CertificateVerify. A server whose +-- hook accepts that must go on to ChangeCipherSpec rather than wait for a +-- CertificateVerify. +handshake_client_auth_empty :: Version -> IO () +handshake_client_auth_empty 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]) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return Nothing + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = acceptEmpty + } + } + runTLSSimple (clientParam', serverParam') + where + acceptEmpty chain + | isNullCertificateChain chain = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + +-- RFC 5246 Section 7.4.6: a client asked for a certificate sends the +-- message even when it has none. Here it is cut out on the wire; the +-- Finished no longer matches, but the server must stop before that. +handshake12_client_cert_omitted :: IO () +handshake12_client_cert_omitted = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return Nothing + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + ccsSent <- newIORef False + let params = (clientParam', serverParam') + withPairContextWith (dropHandshake12 11 ccsSent, id) params $ + \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` rejectedAsUnexpected) + (void (E.try (handshake cctx) :: IO (Either E.SomeException ()))) + +-- A TLS 1.2 client needs the server's Certificate for every key exchange +-- it implements, and ServerKeyExchange for (EC)DHE. One of them is cut +-- out on the wire, and the client must say so rather than fail later. +handshake12_server_message_omitted :: Word8 -> IO () +handshake12_server_message_omitted typ = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + ccsSent <- newIORef False + withPairContextWith (id, dropHandshake12 typ ccsSent) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either E.SomeException ()))) + (handshake cctx `shouldThrow` rejectedAsUnexpected) + +-- | Cut the handshake messages of a type out of what a TLS 1.2 peer sends +-- in clear, that is, before its ChangeCipherSpec. +dropHandshake12 :: Word8 -> IORef Bool -> Backend -> Backend +dropHandshake12 typ = mapHandshake12 $ \m -> if B.head m == typ then "" else m + +-- | Change each handshake message, header included, that a TLS 1.2 peer +-- sends in clear. +mapHandshake12 + :: (B.ByteString -> B.ByteString) -> IORef Bool -> Backend -> Backend +mapHandshake12 f ccsSent be = + be + { backendSend = \bs -> do + done <- readIORef ccsSent + when (B.take 1 bs == B.singleton 20) $ writeIORef ccsSent True + backendSend be $ if done then bs else stripRecords bs + } + where + stripRecords bs + | B.length bs < 5 = bs + | otherwise = + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (body, rest) = B.splitAt len $ B.drop 5 bs + body' + | B.head bs == 22 = stripMessages body + | otherwise = body + len' = B.length body' + hdr = B.take 3 bs <> B.pack [fromIntegral (len' `div` 256), fromIntegral len'] + in (if B.null body' then "" else hdr <> body') <> stripRecords rest + stripMessages m + | B.length m < 4 = m + | otherwise = + let len = + fromIntegral (B.index m 1) * 65536 + + fromIntegral (B.index m 2) * 256 + + fromIntegral (B.index m 3) + (msg, rest) = B.splitAt (4 + len) m + in f msg <> stripMessages rest + +-- A Certificate message whose lengths are right but whose certificate is +-- not DER is answered with bad_certificate, not decode_error. The server's +-- certificate is zeroed on the wire, or replaced with an empty one. +handshake12_corrupt_certificate :: Bool -> IO () +handshake12_corrupt_certificate empty = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + ccsSent <- newIORef False + let corrupt m + | B.head m == 11 = + let certLen = + fromIntegral (B.index m 7) * 65536 + + fromIntegral (B.index m 8) * 256 + + fromIntegral (B.index m 9) + (hdr, rest) = B.splitAt 10 m + -- The ASN.1Cert vector has at least one byte. + emptyCert = B.pack [11, 0, 0, 6, 0, 0, 3, 0, 0, 0] + in if empty + then emptyCert + else hdr <> B.replicate certLen 0 <> B.drop certLen rest + | otherwise = m + withPairContextWith + (id, mapHandshake12 corrupt ccsSent) + (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either E.SomeException ()))) + (handshake cctx `shouldThrow` alertOf expected) + where + expected = if empty then DecodeError else BadCertificate + alertOf ad (HandshakeFailed err) = errorToAlertDescription err == ad + alertOf _ _ = False + +-- In TLS 1.2 a client certificate with an Ed25519 or Ed448 key is asked +-- for with ecdsa_sign (RFC 8422 Section 3.1). The Ed25519 and Ed448 +-- certificate types of this library are synthetic and have no code point, +-- so they must not reach the wire. +handshake12_cert_request_types :: IO () +handshake12_cert_request_types = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + ref <- newIORef Nothing + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return Nothing + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = + supportedHashSignatures defaultSupported + } + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + record hs@(CertRequest certTypes _ _) = writeIORef ref (Just certTypes) >> return hs + record hs = return hs + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv cctx record + concurrently_ (handshake sctx) (handshake cctx) + mtypes <- readIORef ref + case mtypes of + Nothing -> expectationFailure "no CertificateRequest received" + Just certTypes -> do + certTypes `shouldSatisfy` all (`elem` defined) + certTypes `shouldContain` [CertificateType_ECDSA_Sign] + where + defined = + [ CertificateType_RSA_Sign + , CertificateType_DSA_Sign + , CertificateType_ECDSA_Sign + ] + +-- RFC 5246 Section 7.4.8: a TLS 1.2 CertificateVerify algorithm for +-- another type of key than the certificate's has a field that is +-- incorrect, an illegal_parameter, even when onUnverifiedClientCert would +-- accept a signature that does not verify. One for an RSA key that still +-- does not fit it, RSASSA-PSS for an rsaEncryption key, is a signature +-- 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 + :: SignatureScheme -> Selector TLSException -> IO () +handshake12_client_cert_verify_sigalg alg rejected = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + acceptUnverified = alg == ECDSA_SECP256R1_SHA256 + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + , onUnverifiedClientCert = return acceptUnverified + } + } + unfit (CertVerify (DigitallySigned _ sig)) = + pure $ CertVerify (DigitallySigned alg sig) + unfit hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx unfit + concurrently_ + (handshake sctx `shouldThrow` rejected) + (void (E.try (handshake cctx) :: IO (Either TLSException ()))) + r `shouldSatisfy` isJust + +-- The same for the signature of ServerKeyExchange, which the client used to +-- answer with an ErrorCall and internal_error. +handshake12_server_key_xchg_sigalg + :: SignatureScheme -> Selector TLSException -> IO () +handshake12_server_key_xchg_sigalg alg rejected = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + 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 + -- known: curve type and group, the point, then the algorithm. + unfit (ServerKeyXchg (SKX_Unparsed bs)) = + let off = 4 + fromIntegral (B.index bs 3) + in pure $ + ServerKeyXchg $ + SKX_Unparsed $ + 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 + contextHookSetHandshakeRecv cctx unfit + concurrently_ + (void (E.try (handshake sctx) :: IO (Either TLSException ()))) + (handshake cctx `shouldThrow` rejected) + r `shouldSatisfy` isJust + +-- ecdsa_sha224 is a combination TLS 1.2 allows and this library does not +-- implement. Configured on both sides, it must not be chosen and then fail +-- to sign with an ErrorCall; the handshake fails with an alert instead. +handshake12_unimplemented_sigalg :: IO () +handshake12_unimplemented_sigalg = do + let cipher = cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 + sha224 = defaultSupported{supportedHashSignatures = [ECDSA_SHA224]} + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + creds <- generate arbitraryCredentialsOfEachType + let cred = head [c | c@(_, PrivKeyEC _) <- creds] + clientParam' = + clientParam + { clientSupported = + sha224{supportedCiphers = [cipher], supportedVersions = [TLS12]} + } + serverParam' = + serverParam + { serverSupported = + sha224{supportedCiphers = [cipher], supportedVersions = [TLS12]} + , serverShared = + (serverShared serverParam){sharedCredentials = Credentials [cred]} + } + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` rejectedAsHandshakeFailure) + (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 () +handshake_certificate_rejection_details = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + logRef <- newIORef [] + chainRef <- newIORef Nothing + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [UnknownCA] + } + , clientDebug = + (clientDebug clientParam) + { debugError = \msg -> modifyIORef logRef (msg :) + } + } + withPairContextWith (id, id) (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either TLSException ()))) + (handshake cctx `shouldThrow` rejectedWithDetails) + Just (CertificateChain certs) <- readIORef chainRef + logs <- readIORef logRef + let begin = "-----BEGIN CERTIFICATE-----" + pems = sum [length (filter (== begin) (lines l)) | l <- logs] + pems `shouldBe` length certs + where + rejectedWithDetails (HandshakeFailed (Error_Protocol msg UnknownCa)) = + "[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 +-- library used to throw on, which ended the handshake with internal_error. +handshake13_client_cert_verify_malformed_ecdsa + :: (B.ByteString -> B.ByteString) -> IO () +handshake13_client_cert_verify_malformed_ecdsa corrupt = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + creds <- generate arbitraryCredentialsOfEachType + let cred = head [c | c@(_, PrivKeyEC _) <- creds] + clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + malform (CertVerify13 (DigitallySigned alg sig)) = + pure $ CertVerify13 (DigitallySigned alg (corrupt sig)) + malform hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv sctx malform + concurrently_ + ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsDecryptError) + ( void + (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString)) + ) + r `shouldSatisfy` isJust + +rejectedAsDecryptError :: TLSException -> Bool +rejectedAsDecryptError (HandshakeFailed (Error_Protocol _ DecryptError)) = True +rejectedAsDecryptError _ = False + +-- RFC 8446 Section 6.2: a CertificateVerify whose algorithm may not be used +-- with the certificate's key has a field that is incorrect, which is an +-- illegal_parameter; decrypt_error is for a signature that does not verify. +-- The client signs with RSA-PSS for an rsaEncryption key and the server +-- reads the algorithm as rsa_pss_pss_sha256, which needs an RSASSA-PSS key. +handshake13_client_cert_verify_unfit_sigalg :: IO () +handshake13_client_cert_verify_unfit_sigalg = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + unfit (CertVerify13 (DigitallySigned _ sig)) = + pure $ + CertVerify13 (DigitallySigned RSA_PSS_PSS_SHA256 sig) + unfit hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv sctx unfit + concurrently_ + ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsIllegalParameter) + ( void + (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString)) + ) + r `shouldSatisfy` isJust + +rejectedAsIllegalParameter :: TLSException -> Bool +rejectedAsIllegalParameter (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True +rejectedAsIllegalParameter (Terminated _ _ (Error_Protocol _ IllegalParameter)) = True +rejectedAsIllegalParameter _ = False + +-- A server that receives a ClientHello whose legacy_version is higher than +-- its own, without supported_versions, negotiates the highest version it +-- supports (RFC 5246 Appendix E.1, RFC 9846 Section 4.3.1). The +-- ClientHello's legacy_version is raised on its way to the server, and the +-- handshake must still reach the version both sides support. +handshake_high_legacy_version :: Version -> Version -> IO () +handshake_high_legacy_version version legacy = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + let raise (ClientHello ch) = pure $ ClientHello ch{chVersion = legacy} + raise hs = pure hs + withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx raise + concurrently_ (handshake sctx) (handshake cctx) + info <- contextGetInformation sctx + (infoVersion <$> info) `shouldBe` Just version + +-- RFC 8422 Section 5.1.2: ec_point_format_list is <1..2^8-1>, and a +-- client naming one of its curves in supported_groups must offer the +-- uncompressed format. The ClientHello's ec_point_formats is replaced +-- on its way to the server, which must refuse it. +handshake12_ec_point_formats + :: B.ByteString -> Selector TLSException -> IO () +handshake12_ec_point_formats formats rejected = do + CSP12 (cparams, sparams) <- generate arbitrary + let cparams' = + cparams + { clientSupported = + (clientSupported cparams){supportedGroups = [X25519]} + } + sparams' = + sparams + { serverSupported = + (serverSupported sparams){supportedGroups = [X25519]} + } + replace (ClientHello ch) = + pure $ + ClientHello + ch + { chExtensions = + filter + (\(ExtensionRaw eid _) -> eid /= EID_EcPointFormats) + (chExtensions ch) + ++ [ExtensionRaw EID_EcPointFormats formats] + } + replace hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (cparams', sparams') $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx replace + concurrently_ + (handshake sctx `shouldThrow` rejected) + (void (E.try (handshake cctx) :: IO (Either TLSException ()))) + r `shouldSatisfy` isJust + +rejectedAsDecodeError :: TLSException -> Bool +rejectedAsDecodeError (HandshakeFailed (Error_Protocol _ DecodeError)) = True +rejectedAsDecodeError _ = False + +-- RFC 8449 Section 4: a record size limit binds the peer only when the +-- extension is negotiated. Only one side sets limitRecordSize, so the +-- extension is not negotiated, and a record of 2^14 octets from the other +-- side must be received rather than refused with record_overflow. +record_size_limit_unnegotiated :: Version -> Bool -> IO () +record_size_limit_unnegotiated version clientLimited = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + let limited shared = shared{sharedLimit = (sharedLimit shared){limitRecordSize = Just 1024}} + clientParam' + | clientLimited = clientParam{clientShared = limited $ clientShared clientParam} + | otherwise = clientParam + serverParam' + | clientLimited = serverParam + | otherwise = serverParam{serverShared = limited $ serverShared serverParam} + payload = B.replicate 16384 0x61 + send ctx = handshake ctx >> sendData ctx (L.fromStrict payload) + received <- newIORef B.empty + let recv ctx = do + handshake ctx + let loop acc + | B.length acc >= B.length payload = writeIORef received acc + | otherwise = recvData ctx >>= \bs -> loop (acc <> bs) + loop B.empty + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> + if clientLimited + then concurrently_ (send sctx) (recv cctx) + else concurrently_ (recv sctx) (send cctx) + r `shouldSatisfy` isJust + readIORef received `shouldReturn` payload + +-- RFC 8449 Section 4: with record_size_limit negotiated, each side keeps +-- to the other's limit. Both sides set limitRecordSize, which a TLS 1.3 +-- server returns in EncryptedExtensions, and 2^14 octets sent by one side +-- must reach the other in records within its limit. +record_size_limit_negotiated :: Version -> Bool -> IO () +record_size_limit_negotiated version serverSends = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + let limited shared = shared{sharedLimit = (sharedLimit shared){limitRecordSize = Just 1024}} + clientParam' = clientParam{clientShared = limited $ clientShared clientParam} + serverParam' = serverParam{serverShared = limited $ serverShared serverParam} + payload = B.replicate 16384 0x61 + send ctx = handshake ctx >> sendData ctx (L.fromStrict payload) + received <- newIORef B.empty + let recv ctx = do + handshake ctx + let loop acc + | B.length acc >= B.length payload = writeIORef received acc + | otherwise = recvData ctx >>= \bs -> loop (acc <> bs) + loop B.empty + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> + if serverSends + then concurrently_ (send sctx) (recv cctx) + else concurrently_ (recv sctx) (send cctx) + r `shouldSatisfy` isJust + readIORef received `shouldReturn` payload + +handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO () +handshake_client_auth_fail (clientParam, serverParam) = do + let clientVersions = supportedVersions $ clientSupported clientParam + serverVersions = supportedVersions $ serverSupported serverParam + version = maximum (clientVersions `intersect` serverVersions) + cred <- generate (arbitraryClientCredential version) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + runTLSFailure (clientParam', serverParam') handshake handshake + where + validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA) + +-------------------------------------------------------------- + +handshake_ems :: (EMSMode, EMSMode) -> IO () +handshake_ems (cems, sems) = do + params <- generate arbitrary + let params' = setEMSMode (cems, sems) params + version = getConnectVersion params' + emsVersion = version >= TLS10 && version <= TLS12 + use = cems /= NoEMS && sems /= NoEMS + require = cems == RequireEMS || sems == RequireEMS + p info = infoExtendedMainSecret info == (emsVersion && use) + if emsVersion && require && not use + then runTLSFailure params' handshake handshake + else runTLSPredicate params' (maybe False p) + +newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show) + +instance Arbitrary CompatEMS where + arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible) + where + compatible (NoEMS, RequireEMS) = False + compatible (RequireEMS, NoEMS) = False + compatible _ = True + +handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO () +handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + plainParams <- generate arbitrary + let params = + setEMSMode ems $ + setPairParamsSessionManagers sessionManagers plainParams + + runTLSSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = + setEMSMode ems2 $ + setPairParamsSessionResuming (fromJust sessionParams) params + + let version = getConnectVersion params2 + emsVersion = version >= TLS10 && version <= TLS12 + + if emsVersion && use ems && not (use ems2) + then runTLSFailure params2 handshake handshake + else do + runTLSSimple params2 + mSessionParams2 <- readClientSessionRef sessionRefs + let sameSession = sessionParams == mSessionParams2 + sameUse = use ems == use ems2 + when emsVersion (sameSession `shouldBe` sameUse) + where + use (NoEMS, _) = False + use (_, NoEMS) = False + use _ = True + +-------------------------------------------------------------- + +handshake_alpn :: (ClientParams, ServerParams) -> IO () +handshake_alpn (clientParam, serverParam) = do + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onSuggestALPN = return $ Just ["h2", "http/1.1"] + } + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onALPNClientSuggest = Just alpn + } + } + params' = (clientParam', serverParam') + runTLSSuccess params' hsClient hsServer + where + hsClient ctx = do + handshake ctx + proto <- getNegotiatedProtocol ctx + proto `shouldBe` Just "h2" + hsServer ctx = do + handshake ctx + proto <- getNegotiatedProtocol ctx + proto `shouldBe` Just "h2" + alpn xs + | "h2" `elem` xs = return "h2" + | otherwise = return "http/1.1" + +handshake_alpn_rejects_unoffered_server_selection :: IO () +handshake_alpn_rejects_unoffered_server_selection = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + let params = alpnParams clientParam serverParam (const $ pure "h2") + withPairContextWith (id, id) params $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` serverRejectedUnofferedALPN) + (handshake cctx `shouldThrow` anyTLSException) + +handshake_alpn_rejects_unoffered_client_selection :: IO () +handshake_alpn_rejects_unoffered_client_selection = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + let params = alpnParams clientParam serverParam (pure . unsafeHead) + withPairContextWith (id, id) params $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv cctx tamperALPN + concurrently_ + (handshake sctx `shouldThrow` anyTLSException) + (handshake cctx `shouldThrow` clientRejectedUnofferedALPN) + where + tamperALPN (EncryptedExtensions13 exts) = + pure $ EncryptedExtensions13 $ map replaceALPN exts + tamperALPN hs = pure hs + replaceALPN ext@(ExtensionRaw eid _) + | eid == EID_ApplicationLayerProtocolNegotiation = + toExtensionRaw $ ApplicationLayerProtocolNegotiation ["h2"] + | otherwise = ext + +alpnParams + :: ClientParams + -> ServerParams + -> ([B.ByteString] -> IO B.ByteString) + -> (ClientParams, ServerParams) +alpnParams clientParam serverParam select = + ( clientParam + { clientHooks = + (clientHooks clientParam) + { onSuggestALPN = pure $ Just ["http/1.1"] + } + } + , serverParam + { serverHooks = + (serverHooks serverParam) + { onALPNClientSuggest = Just select + } + } + ) + +serverRejectedUnofferedALPN :: TLSException -> Bool +serverRejectedUnofferedALPN (HandshakeFailed (Error_Protocol msg alert)) = + msg == "ALPN callback selected a protocol not offered by the client" + && alert == NoApplicationProtocol +serverRejectedUnofferedALPN _ = False + +clientRejectedUnofferedALPN :: TLSException -> Bool +clientRejectedUnofferedALPN (HandshakeFailed (Error_Protocol msg alert)) = + msg == "server selected an ALPN protocol not offered by the client" + && alert == IllegalParameter +clientRejectedUnofferedALPN _ = False + +-- RFC 6066 Section 3: HostName is <1..2^16-1>, so a client with an +-- empty server name sends no server_name, and the server sees none. +handshake_sni_empty :: IO () +handshake_sni_empty = do + CSP12 (clientParam, serverParam) <- generate arbitrary + let clientParam' = clientParam{clientServerIdentification = ("", "")} + runTLSSuccess (clientParam', serverParam) hs hs + where + hs ctx = do + handshake ctx + msni <- getClientSNI ctx + msni `shouldBe` Nothing + +-- RFC 6066 Section 3: the server_name_list MUST NOT contain more than one +-- name of the same name_type, and HostName is an ASCII DNS host name. The +-- ClientHello's server_name is replaced on its way to the server, which +-- must refuse it with illegal_parameter. +handshake_sni_illegal :: [B.ByteString] -> IO () +handshake_sni_illegal names = do + CSP12 (clientParam, serverParam) <- generate arbitrary + let entry name = + B.concat [B.pack [0, len `shiftR` 8, len], name] + where + len = fromIntegral $ B.length name + list = B.concat $ map entry names + listLen = fromIntegral $ B.length list + sni = B.concat [B.pack [listLen `shiftR` 8, listLen], list] + replace (ClientHello ch) = + pure $ + ClientHello + ch + { chExtensions = + ExtensionRaw EID_ServerName sni + : filter + (\(ExtensionRaw eid _) -> eid /= EID_ServerName) + (chExtensions ch) + } + replace hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx replace + concurrently_ + (handshake sctx `shouldThrow` rejectedAsIllegalParameter) + (void (E.try (handshake cctx) :: IO (Either TLSException ()))) + r `shouldSatisfy` isJust + +handshake_sni :: (ClientParams, ServerParams) -> IO () +handshake_sni (clientParam, serverParam) = do + ref <- newIORef Nothing + let clientParam' = + clientParam + { clientServerIdentification = (serverName, "") + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onServerNameIndication = onSNI ref + } + } + params' = (clientParam', serverParam') + runTLSSuccess params' hsClient hsServer + receivedName <- readIORef ref + receivedName `shouldBe` Just (Just serverName) + where + hsClient ctx = do + handshake ctx + msni <- getClientSNI ctx + expectMaybe "C: SNI should be Just" serverName msni + hsServer ctx = do + handshake ctx + msni <- getClientSNI ctx + expectMaybe "S: SNI should be Just" serverName msni + onSNI ref name = do + mx <- readIORef ref + mx `shouldBe` Nothing + writeIORef ref (Just name) + return (Credentials []) + serverName = "haskell.org" + +-------------------------------------------------------------- + +newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP12 where + arbitrary = CSP12 <$> arbitraryPairParams12 + +handshake12_renegotiation :: CSP12 -> IO () +handshake12_renegotiation (CSP12 (cparams, sparams)) = do + renegDisabled <- generate arbitrary + let sparams' = + sparams + { serverSupported = + (serverSupported sparams) + { supportedClientInitiatedRenegotiation = not renegDisabled + } + } + if renegDisabled + then runTLSFailure (cparams, sparams') hsClient hsServer + else runTLSSimple (cparams, sparams') + where + hsClient ctx = handshake ctx >> handshake ctx + -- recvData receives the alert from the second handshake + hsServer ctx = handshake ctx >> void (recvData ctx) + +-- RFC 5246 Section 6.2.1: application data may come between the handshake +-- messages of a renegotiation. The server sends some before it reads the +-- client's ClientHello, so it reaches the client ahead of ServerHello. +handshake12_renegotiation_interleaved :: IO () +handshake12_renegotiation_interleaved = do + CSP12 (cparams, sparams) <- generate arbitrary + let sparams' = + sparams + { serverSupported = + (serverSupported sparams) + { supportedClientInitiatedRenegotiation = True + } + } + sent <- newEmptyMVar + r <- timeout 10000000 $ + withPairContextWith (id, id) (cparams, sparams') $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + concurrently_ + ( do + sendData sctx "during" + putMVar sent () + recvData sctx `shouldReturn` "after" + ) + ( do + takeMVar sent + handshake cctx + recvData cctx `shouldReturn` "during" + sendData cctx "after" + ) + r `shouldSatisfy` isJust + +-- RFC 5246 Section 7.4.1.1: a client ignores HelloRequest while it is +-- negotiating. One is put ahead of the server's ChangeCipherSpec. +handshake12_hello_request_ignored :: IO () +handshake12_hello_request_ignored = do + CSP12 params <- generate arbitrary + sends <- newIORef (0 :: Int) + let injectHelloRequest be = + be + { backendSend = \bs -> do + n <- atomicModifyIORef' sends $ \i -> (i + 1, i) + when (n == 1) $ backendSend be $ B.pack [22, 3, 3, 0, 4, 0, 0, 0, 0] + backendSend be bs + } + r <- timeout 10000000 $ + withPairContextWith (id, injectHelloRequest) params $ \(cctx, sctx) -> + concurrently_ (handshake sctx) (handshake cctx) + r `shouldSatisfy` isJust + +-- RFC 5746 Section 3.7: when a connection with secure renegotiation is +-- renegotiated, ClientHello must not contain the SCSV and must contain +-- the renegotiation_info extension. The second ClientHello is tampered +-- with on its way to the server, which must abort with handshake_failure. +handshake12_renegotiation_tampered :: (ClientHello -> ClientHello) -> IO () +handshake12_renegotiation_tampered tamper = do + CSP12 (cparams, sparams) <- generate arbitrary + let cparams' = + cparams + { clientSupported = + (clientSupported cparams) + { supportedSecureRenegotiation = True + } + } + sparams' = + sparams + { serverSupported = + (serverSupported sparams) + { supportedSecureRenegotiation = True + , supportedClientInitiatedRenegotiation = True + } + } + count <- newIORef (0 :: Int) + let tamperSecond (ClientHello ch) = do + n <- atomicModifyIORef' count $ \i -> (i + 1, i) + pure $ ClientHello $ if n == 0 then ch else tamper ch + tamperSecond hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (cparams', sparams') $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx tamperSecond + concurrently_ (handshake sctx) (handshake cctx) + concurrently_ + (recvData sctx `shouldThrow` rejectedAsHandshakeFailure) + ( void + (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString)) + ) + r `shouldSatisfy` isJust + +rejectedAsHandshakeFailure :: TLSException -> Bool +rejectedAsHandshakeFailure (HandshakeFailed (Error_Protocol _ HandshakeFailure)) = True +rejectedAsHandshakeFailure (Terminated _ _ (Error_Protocol _ HandshakeFailure)) = True +rejectedAsHandshakeFailure _ = False + +handshake12_session_resumption :: CSP12 -> IO () +handshake12_session_resumption (CSP12 plainParams) = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers plainParams + + runTLSSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSPredicate params2 (maybe False infoTLS12Resumption) + +-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer its +-- cipher suite. When it asks to resume one and offers none the server can +-- use, that is what is reported -- illegal_parameter, as when a cipher could +-- be chosen -- rather than the missing common cipher. +handshake12_session_resumption_cipher_missing :: CSP12 -> IO () +handshake12_session_resumption_cipher_missing (CSP12 plainParams) = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + params = setPairParamsSessionManagers sessionManagers plainParams + runTLSSimple params + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + -- TLS_RSA_WITH_NULL_MD5, which the server does not support + nullCiphers (ClientHello ch) = pure $ ClientHello ch{chCiphers = [CipherId 0x0001]} + nullCiphers hs = pure hs + withPairContextWith (id, id) params2 $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx nullCiphers + concurrently_ + (handshake sctx `shouldThrow` serverRejectedMissingCipher) + (handshake cctx `shouldThrow` anyTLSException) + +serverRejectedMissingCipher :: TLSException -> Bool +serverRejectedMissingCipher (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True +serverRejectedMissingCipher _ = False + +-- RFC 5077 Sections 3.2 and 3.3: a server sends the session_ticket +-- extension and NewSessionTicket only to a client that sent the +-- extension. The client's session_ticket is removed on its way to a +-- server whose session manager uses tickets, and the client must then +-- receive neither. +handshake12_session_ticket_unoffered :: IO () +handshake12_session_ticket_unoffered = do + CSP12 (cparams, sparams) <- generate arbitrary + let sparams' = + sparams + { serverShared = + (serverShared sparams){sharedSessionManager = oneSessionTicket} + } + unoffer (ClientHello ch) = + pure $ + ClientHello + ch + { chExtensions = + filter + (\(ExtensionRaw eid _) -> eid /= EID_SessionTicket) + (chExtensions ch) + } + unoffer hs = pure hs + received <- newIORef [] + let record hs = modifyIORef received (hs :) >> pure hs + withPairContextWith (id, id) (cparams, sparams') $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx unoffer + contextHookSetHandshakeRecv cctx record + concurrently_ (handshake sctx) (handshake cctx) + hss <- readIORef received + let ticketExt (ServerHello sh) = + any (\(ExtensionRaw eid _) -> eid == EID_SessionTicket) (shExtensions sh) + ticketExt _ = False + newTicket NewSessionTicket{} = True + newTicket _ = False + filter (\h -> ticketExt h || newTicket h) hss `shouldBe` [] + +handshake12_session_ticket :: CSP12 -> IO () +handshake12_session_ticket (CSP12 plainParams) = do + sessionRefs <- twoSessionRefs + let sessionManagers0 = twoSessionManagers sessionRefs + sessionManagers = (fst sessionManagers0, oneSessionTicket) + + let params = setPairParamsSessionManagers sessionManagers plainParams + + runTLSSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSPredicate params2 (maybe False infoTLS12Resumption) + +-------------------------------------------------------------- + +handshake13_full :: CSP13 -> IO () +handshake13_full (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +-- A handshake that succeeds, for each group whose key exchange is a KEM. +-- +-- Until this was added the suite had one ML-KEM test and it was a negative +-- one: a zero X25519 part, rejected before any shared secret was computed. +-- Nothing ran encapsulation and decapsulation to the end and checked the two +-- sides reached the same key, which is the one thing a key exchange has to +-- do. An implementation that returned the ciphertext where the secret +-- belongs would have passed everything else here. +handshake13_kem :: Group -> CSP13 -> IO () +handshake13_kem grp (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [grp] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [grp] + , supportedGroupsTLS13 = [[grp]] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +-- A handshake with an ML-DSA server certificate, and one with an ML-DSA +-- client certificate, for each parameter set. +handshake13_mldsa :: Int -> CSP13 -> IO () +handshake13_mldsa n (CSP13 (cli, srv)) = do + creds <- generate arbitraryCredentialsOfEachMLDSA + let cred = creds !! n + -- one group on both sides, so the mode is a full handshake and not + -- a retry, which is what this is asserting about + cliSupported = + (clientSupported cli) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + (serverSupported srv) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverShared = + (serverShared srv){sharedCredentials = Credentials [cred]} + } + ) + runTLSSimple13 params FullHandshake + +handshake13_mldsa_client :: Int -> CSP13 -> IO () +handshake13_mldsa_client n (CSP13 (clientParam, serverParam)) = do + creds <- generate arbitraryCredentialsOfEachMLDSA + let cred = creds !! n + clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \chain -> + if chain == fst cred + then return CertificateUsageAccept + else return (CertificateUsageReject CertificateRejectUnknownCA) + } + , serverSupported = + (serverSupported serverParam) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + } + clientParam'' = + clientParam' + { clientSupported = + (clientSupported clientParam) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + } + runTLSSimple13 (clientParam'', serverParam') FullHandshake + +-- A CertificateVerify naming a scheme the key cannot have made. +-- +-- The second byte of an ML-DSA scheme is one RSASSA-PSS also uses, so code +-- that looks at it alone answers for the wrong algorithm; this is here to +-- catch that, and to pin the alert, which has to be illegal_parameter and +-- not decrypt_error -- the field is wrong, rather than the signature. +handshake13_mldsa_wrong_scheme :: IO () +handshake13_mldsa_wrong_scheme = do + CSP13 (cli, srv) <- generate arbitrary + creds <- generate arbitraryCredentialsOfEachMLDSA + let cred = head creds -- ML-DSA-44 + cliSupported = + (clientSupported cli) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + (serverSupported srv) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverShared = + (serverShared srv){sharedCredentials = Credentials [cred]} + } + ) + withPairContextWith (id, id) params $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv cctx relabel + concurrently_ + (handshake cctx `shouldThrow` clientRejectedTheScheme) + (handshake sctx `shouldThrow` anyTLSException) + where + -- The signature is the one ML-DSA-44 made; only the scheme is changed, + -- to another ML-DSA size, which the key cannot have signed under. + relabel (CertVerify13 (DigitallySigned _ sig)) = + pure $ CertVerify13 $ DigitallySigned MLDSA65 sig + relabel hs = pure hs + +-- The reason as well as the alert. Matching the alert alone would also be +-- satisfied by an illegal_parameter raised for some other reason, which is +-- not what this is asking about. +clientRejectedTheScheme :: TLSException -> Bool +clientRejectedTheScheme (HandshakeFailed (Error_Protocol msg alert)) = + alert == IllegalParameter && "does not fit the public key" `isInfixOf` msg +clientRejectedTheScheme _ = False + +handshake13_hrr :: CSP13 -> IO () +handshake13_hrr (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params HelloRetryRequest + +handshake13_psk :: CSP13 -> IO () +handshake13_psk (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 params HelloRetryRequest + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSSimple13 params2 PreSharedKey + +-- RFC 8446 Section 4.6.1: a TLS 1.3 PSK resumes only a TLS 1.3 session. +-- The server's session manager answers the client's PSK identity with a +-- TLS 1.2 session, which has no ticket information; the server must +-- fall back to a full handshake rather than fail. +handshake13_psk_tls12_session :: IO () +handshake13_psk_tls12_session = do + CSP12 params12 <- generate arbitrary + refs12 <- twoSessionRefs + runTLSSimple $ setPairParamsSessionManagers (twoSessionManagers refs12) params12 + Just (_, sdata12) <- readIORef (snd refs12) + sessionVersion sdata12 `shouldBe` TLS12 + + CSP13 (cli, srv) <- generate arbitrary + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + refs13 <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers refs13) params0 + runTLSSimple13 params HelloRetryRequest + Just sessionParams <- readClientSessionRef refs13 + + let tls12Manager = + noSessionManager + { sessionResume = \_ -> return $ Just sdata12 + , sessionResumeOnlyOnce = \_ -> return $ Just sdata12 + } + params2 = + setPairParamsSessionResuming sessionParams $ + setPairParamsSessionManagers (fst (twoSessionManagers refs13), tls12Manager) params0 + -- The key share is for the group of the earlier session, so no + -- HelloRetryRequest, and the PSK is not used. + runTLSSimple13 params2 FullHandshake + +handshake13_psk_ticket :: CSP13 -> IO () +handshake13_psk_ticket (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers0 = twoSessionManagers sessionRefs + sessionManagers = (fst sessionManagers0, oneSessionTicket) + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 params HelloRetryRequest + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSSimple13 params2 PreSharedKey + +handshake13_psk_fallback :: CSP13 -> IO () +handshake13_psk_fallback (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = + [ cipher13_AES_128_GCM_SHA256 + , cipher13_AES_128_CCM_SHA256 + ] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 params HelloRetryRequest + + -- resumption fails because GCM cipher is not supported anymore, full + -- handshake is not possible because X25519 has been removed, so we are + -- back with P256 after hello retry + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params + srv2' = + srv2{serverSupported = svrSupported'} + svrSupported' = + defaultSupported + { supportedCiphers = [cipher13_AES_128_CCM_SHA256] + , supportedGroups = [P256] + , supportedGroupsTLS13 = [[P256]] + } + + runTLSSimple13 (cli2, srv2') HelloRetryRequest + +-- RFC 8446 Section 4.2.11.2: after HelloRetryRequest the binder covers +-- message_hash(ClientHello1), the HelloRetryRequest and the truncated +-- ClientHello2. It is computed here from the bytes on the wire, so that +-- the client and the server cannot agree on another definition. +handshake13_psk_hrr_binder :: IO () +handshake13_psk_hrr_binder = do + (cli, srv) <- generate arbitraryPairParams13 + let supported grp = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [grp] + , supportedGroupsTLS13 = [[grp]] + } + params0 = + ( cli{clientSupported = (supported X25519){supportedGroups = [X25519, P256]}} + , srv{serverSupported = supported X25519} + ) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + runTLSSimple13 params FullHandshake + + -- The key share is for X25519, the group of the session, and the server + -- now asks for P-256. + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + psk = sessionSecret $ snd $ fromJust sessionParams + cSent <- newIORef [] + sSent <- newIORef [] + let record ref be = be{backendSend = \bs -> modifyIORef ref (bs :) >> backendSend be bs} + params2 = (pc, ps{serverSupported = supported P256}) + withPairContextWith (record cSent, record sSent) params2 $ \(cctx, sctx) -> + concurrently_ (handshake sctx) (handshake cctx) + ch1 : ch2 : _ <- plainHandshakes . B.concat . reverse <$> readIORef cSent + hrr : _ <- plainHandshakes . B.concat . reverse <$> readIORef sSent + let binderLen = 32 + binder = B.drop (B.length ch2 - binderLen) ch2 + truncated = B.take (B.length ch2 - (2 + 1 + binderLen)) ch2 + sha256 :: B.ByteString -> B.ByteString + sha256 = BA.convert . H.hashWith H.SHA256 + messageHash = B.pack [254, 0, 0, fromIntegral binderLen] <> sha256 ch1 + early = hkdfExtract SHA256 (BA.zero 32) (BA.convert psk) :: BA.ScrubbedBytes + binderKey = hkdfExpandLabel SHA256 early "res binder" (sha256 "") 32 :: BA.ScrubbedBytes + finishedKey = hkdfExpandLabel SHA256 binderKey "finished" "" 32 :: B.ByteString + expected = + BA.convert + ( HMAC.hmac finishedKey (sha256 $ messageHash <> hrr <> truncated) + :: HMAC.HMAC H.SHA256 + ) + binder `shouldBe` expected + where + -- The handshake messages of the plaintext records, in order. + plainHandshakes = messages . B.concat . handshakeRecords + handshakeRecords bs + | B.length bs < 5 = [] + | otherwise = + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (body, rest) = B.splitAt len $ B.drop 5 bs + in [body | B.head bs == 22] ++ handshakeRecords rest + messages m + | B.length m < 4 = [] + | otherwise = + let len = + fromIntegral (B.index m 1) * 65536 + + fromIntegral (B.index m 2) * 256 + + fromIntegral (B.index m 3) + (msg, rest) = B.splitAt (4 + len) m + in msg : messages rest + +handshake13_0rtt :: CSP13 -> IO () +handshake13_0rtt (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + cliHooks = + defaultClientHooks + { onSuggestALPN = return $ Just ["h2"] + } + svrHooks = + defaultServerHooks + { onALPNClientSuggest = Just (return . unsafeHead) + } + params0 = + ( cli + { clientSupported = cliSupported + , clientHooks = cliHooks + } + , srv + { serverSupported = svrSupported + , serverHooks = svrHooks + , serverEarlyDataSize = 2048 + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 params HelloRetryRequest + runTLS0rtt params sessionRefs + runTLS0rtt params sessionRefs + where + runTLS0rtt params sessionRefs = do + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + clearClientSessionRef sessionRefs + earlyData <- B.pack <$> generate (someWords8 256) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + params2 = (pc{clientUseEarlyData = True}, ps) + + runTLS0RTT params2 RTT0 earlyData + +handshake13_0rtt_alpn :: IO () +handshake13_0rtt_alpn = do + (cli, srv) <- generate arbitraryPairParams13 + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + cliHooks = + defaultClientHooks + { onSuggestALPN = return $ Just ["h2"] + } + svrHooks = + defaultServerHooks + { onALPNClientSuggest = Just (return . unsafeHead) + } + params0 = + ( cli + { clientSupported = cliSupported + , clientHooks = cliHooks + } + , srv + { serverSupported = svrSupported + , serverHooks = svrHooks + , serverEarlyDataSize = 2048 + } + ) + sessionRefs <- twoSessionRefs + let params = + setPairParamsSessionManagers + (twoSessionManagers sessionRefs) + params0 + runTLSSimple13 params FullHandshake + + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + sessionALPN (snd $ fromJust sessionParams) `shouldBe` Just "h2" + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + pc' = + pc + { clientUseEarlyData = True + , clientHooks = + (clientHooks pc) + { onSuggestALPN = return $ Just ["http/1.1"] + } + } + ps' = + ps + { serverHooks = + (serverHooks ps) + { onALPNClientSuggest = Just (return . unsafeHead) + } + } + runTLS0RTT (pc', ps') PreSharedKey "GET /admin HTTP/1.1\r\n\r\n" + +-- | 'sessionAppData' set when the server saves the session is what +-- 'onAccept0RTT' is given on resumption, and its answer decides 0RTT alone. +handshake13_0rtt_app_data :: Bool -> IO () +handshake13_0rtt_app_data accept = do + (cli, srv) <- generate arbitraryPairParams13 + let supported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = supported} + , srv{serverSupported = supported, serverEarlyDataSize = 2048} + ) + sessionRefs <- twoSessionRefs + let (cmgr, smgr) = twoSessionManagers sessionRefs + smgr' = + smgr + { sessionEstablish = \sid sdata -> + sessionEstablish smgr sid sdata{sessionAppData = Just "limits"} + } + params = setPairParamsSessionManagers (cmgr, smgr') params0 + runTLSSimple13 params FullHandshake + + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + seen <- newIORef Nothing + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + ps' = + ps + { serverHooks = + (serverHooks ps) + { onAccept0RTT = \sdata -> do + writeIORef seen $ sessionAppData sdata + return accept + } + } + mode = if accept then RTT0 else PreSharedKey + runTLS0RTT (pc{clientUseEarlyData = True}, ps') mode "early data" + readIORef seen `shouldReturn` Just "limits" + +handshake13_0rtt_fallback :: CSP13 -> IO () +handshake13_0rtt_fallback (CSP13 (cli, srv)) = do + group0 <- generate $ elements [P256, X25519] + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [group0] + , supportedGroupsTLS13 = [[group0]] + } + params = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverEarlyDataSize = 1024 + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params0 = setPairParamsSessionManagers sessionManagers params + + let mode = if group0 == P256 then FullHandshake else HelloRetryRequest + runTLSSimple13 params0 mode + + -- and resume + mSessionParams <- readClientSessionRef sessionRefs + case mSessionParams of + Nothing -> expectationFailure "session params: Just is expected" + Just sessionParams -> do + earlyData <- B.pack <$> generate (someWords8 256) + group1 <- generate $ elements [P256, X25519] + let (pc, ps) = setPairParamsSessionResuming sessionParams params0 + svrSupported1 = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [group1] + , supportedGroupsTLS13 = [[group1]] + } + params1 = + ( pc{clientUseEarlyData = True} + , ps + { serverEarlyDataSize = 0 + , serverSupported = svrSupported1 + } + ) + -- C: [P256, X25519] + -- S: [group0] + -- C: [P256, X25519] + -- S: [group1] + if group0 == group1 + -- 0-RTT is not allowed, so fallback to PreSharedKey + then runTLS0RTT params1 PreSharedKey earlyData + -- HRR but not allowed for 0-RTT + else runTLSFailure params1 (tlsClient earlyData) tlsServer + where + tlsClient earlyData ctx = do + handshake ctx + sendData ctx $ L.fromStrict earlyData + _ <- recvData ctx + bye ctx + tlsServer ctx = do + handshake ctx + _ <- recvData ctx + bye ctx + +-- The server has forgotten the session, so it answers 0-RTT with a full +-- handshake, and the client must check its certificate. +handshake13_0rtt_psk_rejected :: Bool -> IO () +handshake13_0rtt_psk_rejected wantCert = do + (cli, srv) <- generate arbitraryPairParams13 + let supported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = supported} + , srv{serverSupported = supported, serverEarlyDataSize = 2048} + ) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + runTLSSimple13 params FullHandshake + + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + writeIORef (snd sessionRefs) Nothing + earlyData <- B.pack <$> generate (someWords8 256) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + ps' = + ps + { serverWantClientCert = wantCert + , serverHooks = + (serverHooks ps) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + runTLS0RTT (pc{clientUseEarlyData = True}, ps') FullHandshake earlyData + +-- RFC 9846 Section 4.2.10: a server that has forgotten the session skips +-- the early data, sent in records of the given lengths, up to a record's +-- worth since it accepts no early data itself. +handshake13_0rtt_skip :: [Int] -> Bool -> IO () +handshake13_0rtt_skip lens ok = do + (cli, srv) <- generate arbitraryPairParams13 + let params0 = fixGroupsX25519 (cli, srv{serverEarlyDataSize = 65536}) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + runTLSSimple13 params FullHandshake + Just sessionParams <- readClientSessionRef sessionRefs + writeIORef (snd sessionRefs) Nothing + let (pc, ps) = setPairParamsSessionResuming sessionParams params + chunks = [B.replicate n 0x61 | n <- lens] + len = sum lens + r <- timeout 10000000 $ + withPairContext (pc{clientUseEarlyData = True}, ps{serverEarlyDataSize = 0}) $ + \(cctx, sctx) -> + if ok + then + concurrently_ + ( do + handshake sctx + recvAll sctx len `shouldReturn` B.concat chunks + sendData sctx "ok" + ) + ( do + handshake cctx + mapM_ (sendData cctx . L.fromStrict) chunks + recvData cctx `shouldReturn` "ok" + ) + else + concurrently_ + ((handshake sctx >> recvData sctx) `shouldThrow` tooMuch) + ( void + ( E.try + (handshake cctx >> mapM_ (sendData cctx . L.fromStrict) chunks >> recvData cctx) + :: IO (Either TLSException B.ByteString) + ) + ) + r `shouldSatisfy` isJust + where + recvAll ctx n + | n <= 0 = return "" + | otherwise = do + bs <- recvData ctx + when (B.null bs) $ fail "EOF" + (bs <>) <$> recvAll ctx (n - B.length bs) + tooMuch (HandshakeFailed (Error_Protocol msg UnexpectedMessage)) = "too much" `isInfixOf` msg + tooMuch (Terminated _ _ (Error_Protocol msg UnexpectedMessage)) = "too much" `isInfixOf` msg + tooMuch _ = False + +handshake13_ee_groups :: CSP13 -> IO () +handshake13_ee_groups (CSP13 (cli, srv)) = do + let -- The client prefers P256 + cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} + -- The server prefers X25519 + svrSupported = + (serverSupported srv) + { supportedGroups = [X25519, P256] + , supportedGroupsTLS13 = [[X25519, P256]] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + (_, serverMessages) <- runTLSCapture13 params + -- The server should tell X25519 in supported_groups in EE to client + let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups + eeMessagesHaveExt = + [ any isSupportedGroups exts + | EncryptedExtensions13 exts <- serverMessages + ] + eeMessagesHaveExt `shouldBe` [True] + +handshake13_ec :: CSP13 -> IO () +handshake13_ec (CSP13 (cli, srv)) = do + EC cgrps <- generate arbitrary + EC sgrps <- generate arbitrary + let cliSupported = (clientSupported cli){supportedGroups = cgrps} + svrSupported = + (serverSupported srv) + { supportedGroups = sgrps + , supportedGroupsTLS13 = [sgrps] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +handshake13_ffdhe :: CSP13 -> IO () +handshake13_ffdhe (CSP13 (cli, srv)) = do + FFDHE cgrps <- generate arbitrary + FFDHE sgrps <- generate arbitrary + let cliSupported = (clientSupported cli){supportedGroups = cgrps} + svrSupported = + (serverSupported srv) + { supportedGroups = sgrps + , supportedGroupsTLS13 = [sgrps] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +-- An all-zero X25519 public key decodes, but the shared secret computed +-- from it is all zero and is rejected. The server must answer with +-- illegal_parameter, as it does for X25519 alone, rather than crash. +handshake13_x25519mlkem768_zero_x25519 :: IO () +handshake13_x25519mlkem768_zero_x25519 = do + CSP13 (cli, srv) <- generate arbitrary + let cliSupported = + (clientSupported cli){supportedGroups = [X25519MLKEM768]} + svrSupported = + (serverSupported srv) + { supportedGroups = [X25519MLKEM768] + , supportedGroupsTLS13 = [[X25519MLKEM768]] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + withPairContextWith (id, id) params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx zeroX25519 + concurrently_ + (handshake sctx `shouldThrow` serverRejectedZeroX25519) + (handshake cctx `shouldThrow` anyTLSException) + where + zeroX25519 (ClientHello ch) = + pure $ ClientHello ch{chExtensions = map zeroKeyShare $ chExtensions ch} + zeroX25519 hs = pure hs + zeroKeyShare ext@(ExtensionRaw eid bs) + | eid == EID_KeyShare + , Just (KeyShareClientHello kses) <- extensionDecode MsgTClientHello bs = + toExtensionRaw $ KeyShareClientHello $ map zeroEntry kses + | otherwise = ext + -- The ML-KEM-768 encapsulation key (1184 bytes) is followed by the + -- X25519 public key (32 bytes). + zeroEntry (KeyShareEntry grp key) + | grp == X25519MLKEM768 = + KeyShareEntry grp $ B.take 1184 key <> B.replicate 32 0 + zeroEntry kse = kse + +serverRejectedZeroX25519 :: TLSException -> Bool +serverRejectedZeroX25519 (HandshakeFailed (Error_Protocol msg alert)) = + msg == "invalid client X25519MLKEM768 public key" + && alert == IllegalParameter +serverRejectedZeroX25519 _ = False + +post_handshake_auth :: CSP13 -> IO () +post_handshake_auth (CSP13 (clientParam, serverParam)) = do + cred <- generate (arbitraryClientCredential TLS13) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + if isCredentialDSA cred + then runTLSFailure (clientParam', serverParam') hsClient hsServer + else runTLSSuccess (clientParam', serverParam') hsClient hsServer + where + validateChain cred chain + | chain == fst cred = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + hsClient ctx = do + handshake ctx + sendData ctx "request 1" + recvDataAssert ctx "response 1" + sendData ctx "request 2" + recvDataAssert ctx "response 2" + hsServer ctx = do + handshake ctx + recvDataAssert ctx "request 1" + _ <- requestCertificate ctx -- single request + sendData ctx "response 1" + recvDataAssert ctx "request 2" + _ <- requestCertificate ctx + _ <- requestCertificate ctx -- two simultaneously + sendData ctx "response 2" + +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 +-- receive buffer, so the bytes consumed for the record header would be lost and +-- the caller's next 'recvData' would decode part of a record body as a header. +-- +-- Here the server's first write is one full-size record whose body is made to +-- arrive late, so the peek does hit its deadline with the header already +-- consumed. Before the fix this failed with +-- @Error_Protocol "record exceeding maximum size" RecordOverflow@. +handshake13_client_auth_slow_record :: IO () +handshake13_client_auth_slow_record = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + cred <- generate (arbitraryClientCredential TLS13) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + payload = B.replicate 16384 65 + withPairContextWith (delayBigReads, id) (clientParam', serverParam') $ + \(cCtx, sCtx) -> + concurrently_ + ( do + handshake sCtx + sendData sCtx $ L.fromStrict payload + ) + ( do + handshake cCtx + recvData cCtx `shouldReturn` payload + ) + where + -- Only the body of the big record is held back; every handshake record is + -- far smaller than this threshold and so arrives immediately. + delayBigReads be = + be + { backendRecv = \n -> do + when (n > 4096) $ threadDelay 300000 + backendRecv be n + } + +-- A protected record too short for the cipher cannot be deprotected, which +-- RFC 5246 Section 7.2.2 and RFC 8446 Section 5.2 answer with +-- bad_record_mac. The client's first application data record is cut down +-- to a single byte of ciphertext on its way to the server. +short_record_bad_record_mac :: Version -> Cipher -> IO () +short_record_bad_record_mac version cipher = do + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + armed <- newIORef False + let truncateRecord be = + be + { backendSend = \bs -> do + cut <- readIORef armed + if cut && B.length bs > 6 && B.head bs == 23 + then do + writeIORef armed False + backendSend be $ B.take 3 bs <> B.pack [0, 1] <> B.take 1 (B.drop 5 bs) + else backendSend be bs + } + withPairContextWith (truncateRecord, id) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + recvData sctx `shouldThrow` serverRejectedShortRecord + ) + ( do + handshake cctx + writeIORef armed True + sendData cctx "hello" + void (E.try (recvData cctx) :: IO (Either E.SomeException B.ByteString)) + ) + +-- RFC 8446 Section 5: once keys are in use, only ChangeCipherSpec may come +-- in clear. An injected close_notify must not read as an orderly close. +plaintext_alert13_rejected :: IO () +plaintext_alert13_rejected = do + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher13_AES_128_GCM_SHA256], [cipher13_AES_128_GCM_SHA256]) + armed <- newIORef False + let injectAlert be = + be + { backendSend = \bs -> do + inject <- readIORef armed + if inject && B.take 1 bs == B.singleton 23 + then do + writeIORef armed False + backendSend be $ B.pack [21, 3, 3, 0, 2, 1, 0] + else backendSend be bs + } + withPairContextWith (injectAlert, id) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + recvData sctx `shouldThrow` rejectedPlaintextAlert + ) + ( do + handshake cctx + writeIORef armed True + sendData cctx "hello" + void (E.try (recvData cctx) :: IO (Either E.SomeException B.ByteString)) + ) + +rejectedPlaintextAlert :: TLSException -> Bool +rejectedPlaintextAlert (Terminated _ _ (Error_Protocol _ UnexpectedMessage)) = True +rejectedPlaintextAlert _ = False + +-- A ChangeCipherSpec ahead of the client's second flight, before the server +-- has the keys to switch to. The handshake would refuse it anyway; this +-- keeps the record layer from switching to keys that do not exist. +early_ccs12_rejected :: IO () +early_ccs12_rejected = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + sent <- newIORef (0 :: Int) + let injectCCS be = + be + { backendSend = \bs -> do + n <- readIORef sent + writeIORef sent (n + 1) + -- The first send is ClientHello. + when (n == 1) $ backendSend be $ B.pack [20, 3, 3, 0, 1, 1] + backendSend be bs + } + withPairContextWith (injectCCS, id) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` rejectedAsUnexpected) + (void (E.try (handshake cctx) :: IO (Either E.SomeException ()))) + +serverRejectedShortRecord :: TLSException -> Bool +serverRejectedShortRecord (Terminated _ _ (Error_Protocol _ BadRecordMac)) = True +serverRejectedShortRecord _ = False + +-- The first handshake message a server receives must be a ClientHello; any +-- other is out of order and answered with unexpected_message (RFC 8446 +-- Section 4), whatever its body would decode to. The handshake type of the +-- client's first record is replaced on its way to the server. +server_first_message_unexpected :: Word8 -> IO () +server_first_message_unexpected ty = do + (clientParam, serverParam) <- generate arbitrary + armed <- newIORef True + let retype be = + be + { backendSend = \bs -> do + first <- atomicModifyIORef' armed (\a -> (False, a)) + if first && B.length bs > 5 && B.head bs == 22 + then backendSend be $ B.take 5 bs <> B.singleton ty <> B.drop 6 bs + else backendSend be bs + } + withPairContextWith (retype, id) (clientParam, serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst) + (handshake cctx `shouldThrow` anyTLSException) + +-- ChangeCipherSpec comes between complete handshake messages (RFC 5246 +-- Section 7.1), and a server has no handshake state before its first +-- ClientHello (CVE-2004-0079). The client's first record is split after +-- the given number of bytes of its body, and a ChangeCipherSpec record is +-- sent in between; with 0 it is sent before the whole ClientHello. +server_ccs_interleaved :: Int -> IO () +server_ccs_interleaved n = do + (clientParam, serverParam) <- generate arbitrary + armed <- newIORef True + let interleave be = + be + { backendSend = \bs -> do + first <- atomicModifyIORef' armed (\a -> (False, a)) + if first && B.length bs > 5 + n && B.head bs == 22 + then do + let (hdr, body) = B.splitAt 5 bs + (body1, body2) = B.splitAt n body + record b = B.take 3 hdr <> encodeWord16 (fromIntegral $ B.length b) <> b + ccs = B.pack [20, 3, 3, 0, 1, 1] + if n == 0 + then backendSend be $ ccs <> bs + else backendSend be $ record body1 <> ccs <> record body2 + else backendSend be bs + } + withPairContextWith (interleave, id) (clientParam, serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst) + (handshake cctx `shouldThrow` anyTLSException) + +-- An unknown record type is answered with unexpected_message (RFC 8446 +-- Section 5). The type of the client's first record is replaced; with a +-- length larger than what follows, as an SSLv2 ClientHello reads when taken +-- for a TLS record header, the server must answer from the header alone +-- rather than wait for a body that never comes. A length of 0 keeps the +-- original one. +server_first_record_type_unexpected :: Word8 -> Word16 -> IO () +server_first_record_type_unexpected ty len = do + (clientParam, serverParam) <- generate arbitrary + armed <- newIORef True + let retype be = + be + { backendSend = \bs -> do + first <- atomicModifyIORef' armed (\a -> (False, a)) + if first && B.length bs > 5 && B.head bs == 22 + then do + let lenBytes + | len == 0 = B.take 2 (B.drop 3 bs) + | otherwise = + B.pack [fromIntegral (len `div` 256), fromIntegral (len `mod` 256)] + backendSend be $ + B.singleton ty <> B.take 2 (B.drop 1 bs) <> lenBytes <> B.drop 5 bs + else backendSend be bs + } + r <- timeout 5000000 $ + withPairContextWith (retype, id) (clientParam, serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst) + (handshake cctx `shouldThrow` anyTLSException) + r `shouldSatisfy` isJust + +-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with +-- other record types. After the handshake the client sends a record holding +-- only the first two bytes of a KeyUpdate and then a record of application +-- data. +handshake13_interleaved_app_data :: IO () +handshake13_interleaved_app_data = + serverRefusesProtected13 [(22, B.pack [24, 0]), (23, "hello")] + +-- RFC 9846 Section 6.2: a handshake message that nothing expects after the +-- handshake is unexpected_message. The client sends a Finished and then a +-- record of application data. +handshake13_unexpected_post_handshake :: IO () +handshake13_unexpected_post_handshake = + serverRefusesProtected13 [(22, finished), (23, "hello")] + where + finished = B.pack [20, 0, 0, 32] <> B.replicate 32 0 + +-- RFC 9846 Section 6: the level of an alert is ignored. A handshake_failure +-- at the warning level is an error alert, which the server reports without +-- answering. A close_notify at the fatal level closes the connection. +handshake13_warning_error_alert :: IO () +handshake13_warning_error_alert = + clientSendsProtected13 + [(21, B.pack [1, 40])] + (\sctx -> recvData sctx `shouldThrow` receivedAlert HandshakeFailure) + (\_ -> return ()) + where + receivedAlert ad (Terminated True _ (Error_Protocol _ ad')) = ad == ad' + receivedAlert _ _ = False + +handshake13_fatal_close_notify :: IO () +handshake13_fatal_close_notify = + clientSendsProtected13 + [(21, B.pack [2, 0])] + (\sctx -> recvData sctx `shouldReturn` "") + (\_ -> return ()) + +-- The server must not deliver the data and must answer with +-- unexpected_message. +serverRefusesProtected13 :: [(Word8, B.ByteString)] -> IO () +serverRefusesProtected13 records = + clientSendsProtected13 records serverSide clientSide + where + serverSide sctx = do + r <- E.try (recvData sctx) :: IO (Either TLSException B.ByteString) + case r of + Right d -> expectationFailure $ "server delivered " ++ show d + Left _ -> return () + clientSide cctx = recvData cctx `shouldThrow` peerSentUnexpected + +-- After the handshake the client sends records of these inner types and +-- contents, protected under its application traffic secret. Then each side +-- checks what it receives. +clientSendsProtected13 + :: [(Word8, B.ByteString)] -> (Context -> IO ()) -> (Context -> IO ()) -> IO () +clientSendsProtected13 records serverSide clientSide = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + secretRef <- newIORef Nothing + sendRef <- newIORef (\_ -> return ()) + let logKey line = case words line of + ["CLIENT_TRAFFIC_SECRET_0", _, h] -> writeIORef secretRef (Just h) + _ -> return () + clientParam' = + clientParam + { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey} + } + -- remember the raw sender so that records can be written by hand + capture be = + be + { backendSend = \bs -> do + writeIORef sendRef (backendSend be) + backendSend be bs + } + withPairContextWith (capture, id) (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx >> serverSide sctx) + ( do + handshake cctx + Just h <- readIORef secretRef + send <- readIORef sendRef + let secret = BA.convert (unhex h) :: BA.ScrubbedBytes + key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString + iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString + sequence_ + [ send $ protect13 key iv sqn ty content + | (sqn, (ty, content)) <- zip [0 ..] records + ] + clientSide cctx + ) + where + unhex [] = B.empty + unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest) + unhex _ = error "unhex" + +-- RFC 9846 Section 5: a protected change_cipher_spec is unexpected_message, +-- not dropped like one in clear. The client puts one, under its handshake +-- traffic secret, before its Finished, and never sends a CCS in clear. The +-- Finished then has the wrong sequence number: a server dropping the CCS +-- would fail with bad_record_mac. +handshake13_protected_ccs :: IO () +handshake13_protected_ccs = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + secretRef <- newIORef Nothing + injected <- newIORef False + let logKey line = case words line of + ["CLIENT_HANDSHAKE_TRAFFIC_SECRET", _, h] -> writeIORef secretRef (Just h) + _ -> return () + clientParam' = + clientParam + { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey} + } + inject be = + be + { backendSend = \bs -> do + done <- readIORef injected + msecret <- readIORef secretRef + -- the CCS in clear is never sent + let rs = filter ((/= 20) . B.head) $ records bs + case (done, msecret, break ((== 23) . B.head) rs) of + (False, Just h, (clear, protected@(_ : _))) -> do + writeIORef injected True + let secret = BA.convert (unhex h) :: BA.ScrubbedBytes + key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString + iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString + ccs = protect13 key iv 0 20 (B.singleton 1) + backendSend be $ B.concat (clear ++ ccs : protected) + _ -> backendSend be $ B.concat rs + } + withPairContextWith (inject, id) (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` refusedFor UnexpectedMessage "change_cipher_spec") + (void (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))) + readIORef injected `shouldReturn` True + where + unhex [] = B.empty + unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest) + unhex _ = error "unhex" + records bs + | B.length bs < 5 = [] + | 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 + +-- RFC 9846 Section 5.1: the messages before a key change must end their +-- record. The record holding the ClientHello (the client's first) gets a +-- copy of it, or that holding the ServerHello (the server's first) gets a +-- Finished-shaped message. +handshake13_trailing_after_hello :: Bool -> IO () +handshake13_trailing_after_hello afterCH = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + let params = fixGroupsX25519 (clientParam, serverParam) + ref <- newIORef False + let wraps + | afterCH = (appendToFirstRecord ref id, id) + | otherwise = (id, appendToFirstRecord ref (const trailingFinished)) + r <- timeout 10000000 $ + withPairContextWith wraps params $ \(cctx, sctx) -> + if afterCH + then + concurrently_ + (handshake sctx `shouldThrow` rejectedAsUnexpected) + (void (E.try (handshake cctx) :: IO (Either TLSException ()))) + else + concurrently_ + ( void + (E.try (handshake sctx >> recvData sctx) :: IO (Either TLSException B.ByteString)) + ) + (handshake cctx `shouldThrow` rejectedAsUnexpected) + r `shouldSatisfy` isJust + readIORef ref `shouldReturn` True + +-- As above, for the plaintext ServerHello that the client takes in its +-- receive loop after sending early data. +handshake13_0rtt_trailing_after_server_hello :: IO () +handshake13_0rtt_trailing_after_server_hello = 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 + ref <- newIORef False + r <- timeout 10000000 + $ withPairContextWith + (id, appendToFirstRecord ref (const trailingFinished)) + (pc{clientUseEarlyData = True}, ps) + $ \(cctx, sctx) -> + concurrently_ + ( void + (E.try (handshake sctx >> recvData sctx) :: IO (Either TLSException B.ByteString)) + ) + ( do + handshake cctx + sendData cctx "early" + recvData cctx `shouldThrow` notAligned + ) + r `shouldSatisfy` isJust + readIORef ref `shouldReturn` True + where + notAligned (HandshakeFailed (Error_Protocol msg UnexpectedMessage)) = + "not aligned" `isInfixOf` msg + notAligned _ = False + +-- After the handshake the client sends, protected under its application +-- traffic secret, a record holding a KeyUpdate and a Finished-shaped message, +-- and then application data under the same secret. +handshake13_trailing_after_key_update :: IO () +handshake13_trailing_after_key_update = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + secretRef <- newIORef Nothing + sendRef <- newIORef (\_ -> return ()) + let logKey line = case words line of + ["CLIENT_TRAFFIC_SECRET_0", _, h] -> writeIORef secretRef (Just h) + _ -> return () + clientParam' = + clientParam + { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey} + } + capture be = + be + { backendSend = \bs -> do + writeIORef sendRef (backendSend be) + backendSend be bs + } + r <- timeout 10000000 $ + withPairContextWith (capture, id) (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx >> (recvData sctx `shouldThrow` anyTLSException)) + ( do + handshake cctx + Just h <- readIORef secretRef + send <- readIORef sendRef + let secret = BA.convert (unhexBytes h) :: BA.ScrubbedBytes + key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString + iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString + keyUpdate = B.pack [24, 0, 0, 1, 0] + send $ protect13 key iv 0 22 (keyUpdate <> trailingFinished) + send $ protect13 key iv 1 23 "hello" + recvData cctx `shouldThrow` peerSentUnexpected + ) + 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 +-- KeyUpdates it receives. +handshake13_single_key_update_response :: IO () +handshake13_single_key_update_response = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + 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 + updateKey sctx TwoWay `shouldReturn` True + updateKey sctx TwoWay `shouldReturn` True + sendData sctx "hello" + recvData sctx `shouldReturn` "x" + readIORef updates `shouldReturn` 1 + updateKey sctx TwoWay `shouldReturn` True + sendData sctx "again" + recvData sctx `shouldReturn` "y" + ) + ( do + handshake cctx + recvData cctx `shouldReturn` "hello" + sendData cctx "x" + recvData cctx `shouldReturn` "again" + 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 +-- resumes with the second. +-- RFC 9846 Section 4.6.1: a client resumes only with the SNI of the session. +handshake13_psk_sni :: Bool -> CSP13 -> IO () +handshake13_psk_sni same (CSP13 (cli, srv)) = do + let withName name c = + c + { clientServerIdentification = (name, snd $ clientServerIdentification c) + , clientUseServerNameIndication = True + } + sessionRefs <- twoSessionRefs + let params = + setPairParamsSessionManagers + (twoSessionManagers sessionRefs) + (withName "a.example" cli, srv) + runTLSSimple params + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let name = if same then "a.example" else "b.example" + (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params + offered <- newIORef False + let check hs@(ClientHello ch) = do + let psk (ExtensionRaw eid _) = eid == EID_PreSharedKey + writeIORef offered $ any psk $ chExtensions ch + return hs + check hs = return hs + withPairContextWith (id, id) (withName name cli2, srv2) $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx check + concurrently_ (handshake sctx) (handshake cctx) + readIORef offered `shouldReturn` same + +handshake13_second_psk :: IO () +handshake13_second_psk = do + (cli, srv) <- generate arbitraryPairParams13 + sessionRefs <- twoSessionRefs + let params = + setPairParamsSessionManagers (twoSessionManagers sessionRefs) $ + fixGroupsX25519 (cli, srv) + runTLSSimple13 params FullHandshake + Just (sid, sdata) <- readClientSessionRef sessionRefs + let unknown = + ( B.map (xor 0xff) sid + , sdata{sessionSecret = B.map (xor 0xff) (sessionSecret sdata)} + ) + (pc, ps) = params + runTLSSimple13 + (pc{clientWantSessionResumeList = [unknown, (sid, sdata)]}, ps) + PreSharedKey + +-- RFC 9846 Section 4.1.4: a HelloRetryRequest may carry only a cookie, +-- after which the client sends the same key shares again with the cookie. +-- One with neither changes nothing and is refused with illegal_parameter. +-- The server side is played by hand. +handshake13_hrr_without_key_share :: Bool -> IO () +handshake13_hrr_without_key_share withCookie = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + let cookie = Cookie "a cookie" + r <- timeout 10000000 $ + withPairContext (clientParam, serverParam) $ \(cctx, sctx) -> do + let be = ctxBackend sctx + recvRecord = do + hdr <- backendRecv be 5 + let len = fromIntegral (B.index hdr 3) * 256 + fromIntegral (B.index hdr 4) + body <- backendRecv be len + return (B.head hdr, body) + recvClientHello = do + (ty, body) <- recvRecord + if ty /= 22 + then recvClientHello + else do + let cp = CurrentParams TLS12 Nothing + case decodeHandshake cp HandshakeType_ClientHello (B.drop 4 body) of + Right (ClientHello ch) -> return ch + x -> error $ show x + sendHandshake h = + let bs = encodeHandshake h + len = B.length bs + in backendSend be $ + B.pack [22, 3, 3, fromIntegral (len `div` 256), fromIntegral (len `mod` 256)] + <> bs + concurrently_ + ( do + ch1 <- recvClientHello + sendHandshake $ + ServerHello + SH + { shVersion = TLS12 + , shRandom = hrrRandom + , shSession = chSession ch1 + , shCipher = CipherId 0x1301 + , shComp = 0 + , shExtensions = + toExtensionRaw (SupportedVersionsServerHello TLS13) + : [toExtensionRaw cookie | withCookie] + } + when withCookie $ do + ch2 <- recvClientHello + findExt EID_KeyShare ch2 `shouldBe` findExt EID_KeyShare ch1 + findExt EID_Cookie ch2 `shouldBe` Just (toExtensionRaw cookie) + -- handshake_failure, to end the client + backendSend be $ B.pack [21, 3, 3, 0, 2, 2, 40] + ) + ( if withCookie + then void (E.try (handshake cctx) :: IO (Either TLSException ())) + else handshake cctx `shouldThrow` illegalParameter + ) + r `shouldSatisfy` isJust + where + findExt i ch = find (\(ExtensionRaw eid _) -> eid == i) (chExtensions ch) + illegalParameter (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True + illegalParameter _ = False + +-- The server refuses the ClientHello the function changes, as the +-- selector expects. +-- RFC 9846 Section 4.1.2: the server changes the second ClientHello after +-- HelloRetryRequest with the function, given the first one, and refuses +-- it for the reason or accepts it. +handshake13_hrr_second_hello + :: (ClientHello -> ClientHello -> ClientHello) -> Maybe String -> IO () +handshake13_hrr_second_hello f mreason = do + (cli, srv) <- generate arbitraryPairParams13 + let supported grps = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = grps + , supportedGroupsTLS13 = [grps] + } + params = + ( cli{clientSupported = (supported [X25519]){supportedGroups = [X25519, P256]}} + , srv{serverSupported = supported [P256]} + ) + ref <- newIORef Nothing + let tamper (ClientHello ch) = do + mch1 <- readIORef ref + case mch1 of + Nothing -> writeIORef ref (Just ch) >> pure (ClientHello ch) + Just ch1 -> pure $ ClientHello $ f ch1 ch + tamper h = pure h + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx tamper + case mreason of + Nothing -> concurrently_ (handshake sctx) (handshake cctx) + Just why -> + concurrently_ + (handshake sctx `shouldThrow` refusedFor IllegalParameter why) + (handshake cctx `shouldThrow` anyTLSException) + readIORef ref >>= (`shouldSatisfy` isJust) + +otherRandom + , extensionAdded + , firstKeyShare + , reordered + :: ClientHello -> ClientHello -> ClientHello +otherRandom _ ch = ch{chRandom = ClientRandom $ B.replicate 32 0} +extensionAdded _ ch = + ch{chExtensions = ExtensionRaw (ExtensionID 0xfafa) "" : chExtensions ch} +firstKeyShare ch1 ch = ch{chExtensions = map replace $ chExtensions ch} + where + replace (ExtensionRaw EID_KeyShare _) = + fromJust $ find (\(ExtensionRaw eid _) -> eid == EID_KeyShare) $ chExtensions ch1 + replace e = e +reordered _ ch = ch{chExtensions = reverse $ chExtensions ch} + +serverRefusesHello + :: (ClientParams, ServerParams) + -> (ClientHello -> ClientHello) + -> Selector TLSException + -> IO () +serverRefusesHello params f refused = + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx tamper + concurrently_ + (handshake sctx `shouldThrow` refused) + (handshake cctx `shouldThrow` anyTLSException) + where + tamper (ClientHello ch) = pure $ ClientHello $ f ch + tamper h = pure h + +-- The client refuses the ServerHello the function changes, as the +-- selector expects. +clientRefusesHello + :: (ClientParams, ServerParams) + -> (ServerHello -> ServerHello) + -> Selector TLSException + -> IO () +clientRefusesHello params f refused = + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv cctx tamper + concurrently_ + (handshake sctx `shouldThrow` anyTLSException) + (handshake cctx `shouldThrow` refused) + where + tamper (ServerHello sh) = pure $ ServerHello $ f sh + tamper h = pure h + +withoutExt :: ExtensionID -> ClientHello -> ClientHello +withoutExt i ch = + ch{chExtensions = filter (\(ExtensionRaw eid _) -> eid /= i) $ chExtensions ch} + +refusedWith :: AlertDescription -> TLSException -> Bool +refusedWith ad = refusedFor ad "" + +-- Refused with the alert, for a reason containing the string. +refusedFor :: AlertDescription -> String -> TLSException -> Bool +refusedFor ad needle (HandshakeFailed (Error_Protocol reason ad')) = + ad == ad' && needle `isInfixOf` reason +refusedFor _ _ _ = False + +unhexBytes :: String -> B.ByteString +unhexBytes [] = B.empty +unhexBytes (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhexBytes rest) +unhexBytes _ = error "unhexBytes" + +-- A Finished message with a zero verify_data of SHA-256 size. +trailingFinished :: B.ByteString +trailingFinished = B.pack (20 : 0 : 0 : 32 : replicate 32 0) + +-- Groups fixed so that no HelloRetryRequest happens. +fixGroupsX25519 :: (ClientParams, ServerParams) -> (ClientParams, ServerParams) +fixGroupsX25519 (cli, srv) = + ( cli{clientSupported = (clientSupported cli){supportedGroups = [X25519]}} + , srv + { serverSupported = + (serverSupported srv) + { supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + } + ) + +-- RFC 9846 Section 5.1: handshake records are never empty. The client's +-- ClientHello record gets an empty one before it or in the middle of it. +handshake_empty_handshake_record :: Bool -> IO () +handshake_empty_handshake_record before = do + (clientParam, serverParam) <- generate arbitrary + ref <- newIORef False + let split body + | before = ["", body] + | otherwise = [B.take 10 body, "", B.drop 10 body] + r <- timeout 10000000 $ + withPairContextWith (splitFirstRecord ref split, id) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` refusedFor UnexpectedMessage "empty") + (handshake cctx `shouldThrow` anyTLSException) + r `shouldSatisfy` isJust + readIORef ref `shouldReturn` True + +-- RFC 9846 Section 5.1 lets a handshake message be split into records of +-- any non-zero size. The ClientHello is sent a byte a record, which the +-- default limit of 2048 records accepts and the given limit refuses. +handshake_one_byte_records :: Version -> Maybe Int -> IO () +handshake_one_byte_records ver mlim = do + (clientParam, serverParam) <- + fixGroupsX25519 + <$> generate + (arbitraryPairParamsWithVersionsAndCiphers ([ver], [ver]) (ciphers, ciphers)) + let serverParam' = case mlim of + Nothing -> serverParam + Just lim -> + let shared = serverShared serverParam + in serverParam + { serverShared = + shared{sharedLimit = (sharedLimit shared){limitHandshakeFragment = lim}} + } + ref <- newIORef False + let split = map B.singleton . B.unpack + r <- timeout 10000000 $ + withPairContextWith (splitFirstRecord ref split, id) (clientParam, serverParam') $ + \(cctx, sctx) -> case mlim of + Nothing -> concurrently_ (handshake sctx) (handshake cctx) + Just _ -> + concurrently_ + (handshake sctx `shouldThrow` refusedFor UnexpectedMessage "too many") + (handshake cctx `shouldThrow` anyTLSException) + r `shouldSatisfy` isJust + readIORef ref `shouldReturn` True + where + ciphers + | ver == TLS13 = [cipher13_AES_128_GCM_SHA256] + | otherwise = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] + +-- Sends the body of the first record, which is expected to be a plaintext +-- handshake record, in the records the function splits it into. +splitFirstRecord + :: IORef Bool -> (B.ByteString -> [B.ByteString]) -> Backend -> Backend +splitFirstRecord ref split be = + be + { backendSend = \bs -> do + done <- readIORef ref + if done || B.take 1 bs /= B.singleton 22 + then backendSend be bs + else do + writeIORef ref True + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (body, rest) = B.splitAt len $ B.drop 5 bs + record b = B.take 3 bs <> encodeWord16 (fromIntegral $ B.length b) <> b + backendSend be $ B.concat (map record (split body)) <> rest + } + +-- Puts bytes made from its body at the end of the first record sent, which +-- is expected to be a plaintext handshake record. +appendToFirstRecord + :: IORef Bool -> (B.ByteString -> B.ByteString) -> Backend -> Backend +appendToFirstRecord ref mkExtra be = + be + { backendSend = \bs -> do + done <- readIORef ref + if done || B.take 1 bs /= B.singleton 22 + then backendSend be bs + else do + writeIORef ref True + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (body, rest) = B.splitAt len $ B.drop 5 bs + extra = mkExtra body + len' = len + B.length extra + hdr = + B.take 3 bs + <> B.pack [fromIntegral (len' `div` 256), fromIntegral (len' `mod` 256)] + backendSend be $ hdr <> body <> extra <> rest + } + +-- A ChangeCipherSpec is the single byte 1; any other value is answered with +-- unexpected_message (RFC 8446 Section 5), and so is one carrying two of +-- them. The client's ChangeCipherSpec record is made two bytes long. The +-- groups are fixed so that a TLS 1.3 handshake goes through a +-- HelloRetryRequest -- after which the client sends its ChangeCipherSpec +-- before the second ClientHello -- or not, as the test asks. +malformed_ccs_unexpected :: Version -> Cipher -> [Group] -> [Group] -> IO () +malformed_ccs_unexpected version cipher cgroups sgroups = do + (clientParam0, serverParam0) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + let clientParam = + clientParam0 + { clientSupported = (clientSupported clientParam0){supportedGroups = cgroups} + } + serverParam = + serverParam0 + { serverSupported = + (serverSupported serverParam0) + { supportedGroups = sgroups + , supportedGroupsTLS13 = [sgroups] + } + } + seen <- newIORef False + let ccs = B.pack [20, 3, 3, 0, 1, 1] + doubled = B.pack [20, 3, 3, 0, 2, 1, 1] + double be = + be + { backendSend = \bs -> + if ccs `B.isPrefixOf` bs + then do + writeIORef seen True + backendSend be $ doubled <> B.drop 6 bs + else backendSend be bs + } + -- a TLS 1.3 server takes the client's ChangeCipherSpec and Finished in + -- its first recvData, a TLS 1.2 one in handshake + r <- timeout 10000000 $ + withPairContextWith (double, id) (clientParam, serverParam) $ \(cctx, sctx) -> + concurrently_ + ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsUnexpected) + ( void + (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString)) + ) + r `shouldSatisfy` isJust + readIORef seen `shouldReturn` True + +rejectedAsUnexpected :: TLSException -> Bool +rejectedAsUnexpected (HandshakeFailed (Error_Packet_unexpected _ _)) = True +rejectedAsUnexpected (Terminated _ _ (Error_Packet_unexpected _ _)) = True +rejectedAsUnexpected _ = False + +-- An AES-128-GCM TLS 1.3 record: content and inner type, protected with the +-- record header as additional data and the sequence number in the nonce. +protect13 :: B.ByteString -> B.ByteString -> Word64 -> Word8 -> B.ByteString -> B.ByteString +protect13 key iv sqn innerType content = hdr <> ct <> BA.convert tag + where + len = B.length content + 1 + 16 + hdr = B.pack [23, 3, 3, fromIntegral (len `div` 256), fromIntegral (len `mod` 256)] + sqnBytes = B.pack [fromIntegral (sqn `shiftR` (8 * i)) | i <- [7, 6 .. 0]] + nonce = B.pack $ B.zipWith xor iv (B.replicate 4 0 <> sqnBytes) + aes = throwCryptoError (cipherInit key) :: AES128 + aead = throwCryptoError (aeadInit AEAD_GCM aes nonce) + (AuthTag tag, ct) = aeadSimpleEncrypt aead hdr (content <> B.singleton innerType) 16 + +peerSentUnexpected :: TLSException -> Bool +peerSentUnexpected (Terminated True _ (Error_Protocol _ UnexpectedMessage)) = True +peerSentUnexpected _ = False + +serverRejectedUnexpectedFirst :: TLSException -> Bool +serverRejectedUnexpectedFirst (HandshakeFailed (Error_Packet_unexpected _ _)) = True +serverRejectedUnexpectedFirst _ = False expectJust :: String -> Maybe a -> Expectation expectJust tag mx = case mx of diff --git a/test/PubKey.hs b/test/PubKey.hs --- a/test/PubKey.hs +++ b/test/PubKey.hs @@ -4,6 +4,9 @@ arbitraryECDSAPair, arbitraryEd25519Pair, arbitraryEd448Pair, + arbitraryMLDSA44Pair, + arbitraryMLDSA65Pair, + arbitraryMLDSA87Pair, globalRSAPair, getGlobalRSAPair, knownECCurves, @@ -20,8 +23,10 @@ import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.MLDSA as MLDSA import qualified Crypto.PubKey.RSA as RSA import Crypto.Random +import Data.Proxy (Proxy (..)) import qualified Data.ByteString as B import System.IO.Unsafe import Test.QuickCheck @@ -111,6 +116,27 @@ bytes <- vectorOf 32 arbitrary let priv = fromCryptoPassed $ Ed25519.secretKey (B.pack bytes) return (Ed25519.toPublic priv, priv) + +-- ML-DSA, from a seed drawn here, so a run is reproducible from its seed +-- the way the other pairs are. +arbitraryMLDSAPair + :: MLDSA.MLDSA p + => proxy p -> Gen (MLDSA.VerificationKey p, MLDSA.SigningKey p) +arbitraryMLDSAPair p = do + bytes <- vectorOf MLDSA.seedSize arbitrary + return $ fromCryptoPassed $ MLDSA.keyPairFromSeed p (B.pack bytes) + +arbitraryMLDSA44Pair + :: Gen (MLDSA.VerificationKey MLDSA.MLDSA44, MLDSA.SigningKey MLDSA.MLDSA44) +arbitraryMLDSA44Pair = arbitraryMLDSAPair (Proxy :: Proxy MLDSA.MLDSA44) + +arbitraryMLDSA65Pair + :: Gen (MLDSA.VerificationKey MLDSA.MLDSA65, MLDSA.SigningKey MLDSA.MLDSA65) +arbitraryMLDSA65Pair = arbitraryMLDSAPair (Proxy :: Proxy MLDSA.MLDSA65) + +arbitraryMLDSA87Pair + :: Gen (MLDSA.VerificationKey MLDSA.MLDSA87, MLDSA.SigningKey MLDSA.MLDSA87) +arbitraryMLDSA87Pair = arbitraryMLDSAPair (Proxy :: Proxy MLDSA.MLDSA87) arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) arbitraryEd448Pair = do diff --git a/test/Run.hs b/test/Run.hs --- a/test/Run.hs +++ b/test/Run.hs @@ -16,6 +16,9 @@ runTLSFailure, expectMaybe, newPairContext, + newPairContextWith, + withPairContext, + withPairContextWith, withDataPipe, byeBye, ) where @@ -156,6 +159,16 @@ handshake ctx sendData ctx $ L.fromStrict earlyData _ <- recvData ctx + -- One more exchange, and this one the client starts. Our Finished is + -- not sent by 'handshake' here: 0-RTT defers it, and the receive loop + -- above is what puts it on the wire. The server emits the + -- NewSessionTicket when it reads that Finished, which is after it sent + -- the echo -- so reading the echo is not enough to have seen the + -- ticket, and neither is a byte the server sends straight after it. + -- The server cannot answer this without having read past the Finished + -- first, and records arrive in order. + sendData ctx "x" + recvDataAssert ctx "x" bye ctx mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "C: mode should be Just" mode mmode @@ -165,6 +178,8 @@ chunks <- replicateM (length ls) $ recvData ctx (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData) sendData ctx $ L.fromStrict earlyData + recvDataAssert ctx "x" + sendData ctx "x" bye ctx mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode @@ -187,6 +202,16 @@ handshake ctx sendData ctx $ L.fromStrict earlyData _ <- recvData ctx + -- One more exchange, and this one the client starts. Our Finished is + -- not sent by 'handshake' here: 0-RTT defers it, and the receive loop + -- above is what puts it on the wire. The server emits the + -- NewSessionTicket when it reads that Finished, which is after it sent + -- the echo -- so reading the echo is not enough to have seen the + -- ticket, and neither is a byte the server sends straight after it. + -- The server cannot answer this without having read past the Finished + -- first, and records arrive in order. + sendData ctx "x" + recvDataAssert ctx "x" bye ctx minfo <- contextGetInformation ctx let mmode = minfo >>= infoTLS13HandshakeMode @@ -199,6 +224,8 @@ chunks <- replicateM (length ls) $ recvData ctx (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData) sendData ctx $ L.fromStrict earlyData + recvDataAssert ctx "x" + sendData ctx "x" bye ctx mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode @@ -295,11 +322,15 @@ hsClient ctx d <- readChan queue sendData ctx (L.fromChunks [d]) + -- The server writes after any TLS 1.3 NewSessionTicket, so waiting for + -- this byte ensures the client session manager received the ticket. + recvDataAssert ctx "x" checkCtxFinished ctx bye ctx tlsServer ctx queue = do hsServer ctx d <- recvData ctx + sendData ctx "x" writeChan queue [d] checkCtxFinished ctx bye ctx @@ -326,16 +357,32 @@ withPairContext :: (ClientParams, ServerParams) -> ((Context, Context) -> IO ()) -> IO () -withPairContext params body = +withPairContext = withPairContextWith (id, id) + +withPairContextWith + :: (Backend -> Backend, Backend -> Backend) + -> (ClientParams, ServerParams) + -> ((Context, Context) -> IO a) + -> IO a +withPairContextWith wrapBackends params body = E.bracket - (newPairContext params) + (newPairContextWith wrapBackends params) (\((t1, t2), _) -> killThread t1 >> killThread t2) (\(_, ctxs) -> body ctxs) newPairContext :: (ClientParams, ServerParams) -> IO ((ThreadId, ThreadId), (Context, Context)) -newPairContext (cParams, sParams) = do +newPairContext = newPairContextWith (id, id) + +-- | 'newPairContext' with a hook on each side's 'Backend' -- client first, as +-- with the parameters -- so that a test can control how bytes arrive (delay +-- them, split them). Pass 'id' for a side to leave it alone. +newPairContextWith + :: (Backend -> Backend, Backend -> Backend) + -> (ClientParams, ServerParams) + -> IO ((ThreadId, ThreadId), (Context, Context)) +newPairContextWith (wrapCBackend, wrapSBackend) (cParams, sParams) = do pipe <- newPipe tids <- runPipe pipe let noFlush = return () @@ -343,8 +390,8 @@ let cBackend = Backend noFlush noClose (writePipeC pipe) (readPipeC pipe) let sBackend = Backend noFlush noClose (writePipeS pipe) (readPipeS pipe) - cCtx' <- contextNew cBackend cParams - sCtx' <- contextNew sBackend sParams + cCtx' <- contextNew (wrapCBackend cBackend) cParams + sCtx' <- contextNew (wrapSBackend sBackend) sParams contextHookSetLogging cCtx' (logging "client: ") contextHookSetLogging sCtx' (logging "server: ") diff --git a/test/SecretSpec.hs b/test/SecretSpec.hs new file mode 100644 --- /dev/null +++ b/test/SecretSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SecretSpec where + +import Crypto.Debug (debugShow) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import Data.List (isInfixOf) +import Network.TLS (Version (TLS13)) +import Network.TLS.Extra.Cipher (ciphersuite_default) +import Network.TLS.Internal (SessionData (..)) +import Network.TLS.QUIC +import Test.Hspec + +-- | The traffic secrets reach a QUIC implementation through +-- 'quicInstallKeys', so a trace of what it is handed must not write them to a +-- log. 'debugShow' is how a debugging session asks for them on purpose. +spec :: Spec +spec = do + describe "Show of the QUIC secret types" $ do + it "does not print an early traffic secret" $ + check $ + EarlySecretInfo cipher clientSecret + it "does not print the handshake traffic secrets" $ + check $ + HandshakeSecretInfo cipher (clientSecret, serverSecret) + it "does not print the application traffic secrets" $ + check $ + ApplicationSecretInfo (clientSecret, serverSecret) + describe "Show of a resumable session" $ + it "does not print the session secret" $ do + let shown = show sessionData + show (B.replicate 32 0xa5) `isInfixOf` shown `shouldBe` False + "" `isInfixOf` shown `shouldBe` True + show (B.replicate 32 0xa5) + `isInfixOf` debugShow sessionData + `shouldBe` True + where + sessionData = + SessionData + { sessionVersion = TLS13 + , sessionCipher = 0x1301 + , sessionCompression = 0 + , sessionClientSNI = Just "example.com" + , sessionSecret = B.replicate 32 0xa5 + , sessionGroup = Nothing + , sessionTicketInfo = Nothing + , sessionALPN = Nothing + , sessionMaxEarlyDataSize = 0 + , sessionFlags = [] + , sessionClientCertificate = Nothing + , sessionAppData = Nothing + } + cipher = case ciphersuite_default of + c : _ -> c + [] -> error "ciphersuite_default is empty" + clientSecret = ClientTrafficSecret $ BA.convert $ B.replicate 32 0xa5 + serverSecret = ServerTrafficSecret $ BA.convert $ B.replicate 32 0x5a + hexOf w = concat $ replicate 32 w + check x = do + let shown = show x + hexOf "a5" `isInfixOf` shown `shouldBe` False + hexOf "5a" `isInfixOf` shown `shouldBe` False + "" `isInfixOf` shown `shouldBe` True + hexOf "a5" `isInfixOf` debugShow x `shouldBe` True diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ -cabal-version: >=1.10 +cabal-version: 2.0 name: tls -version: 2.1.14 +version: 2.5.1 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -15,6 +15,8 @@ build-type: Simple extra-source-files: test/*.hs + +extra-doc-files: CHANGELOG.md source-repository head @@ -34,6 +36,7 @@ Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher + Network.TLS.Extra.CipherCBC Network.TLS.Extra.FFDHE Network.TLS.QUIC @@ -78,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 @@ -113,69 +116,31 @@ Network.TLS.Wire Network.TLS.X509 + default-language: Haskell2010 default-extensions: Strict StrictData - default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall build-depends: base >=4.9 && <5, - asn1-encoding >= 0.9 && < 0.10, - asn1-types >= 0.3 && < 0.4, base16-bytestring, - bytestring >= 0.10 && < 0.13, - cereal >= 0.5.3 && < 0.6, - crypton >= 0.34, - crypton-x509 >= 1.7 && < 1.8, - crypton-x509-store >= 1.6 && < 1.7, - crypton-x509-validation >= 1.6.13 && < 1.7, + bytestring >=0.10 && <0.13, + cereal >=0.5.3 && <0.6, + crypton >=2.1.9 && <2.3, + crypton-asn1-encoding >= 0.10.0 && < 0.11, + crypton-asn1-types >= 0.4.1 && < 0.5, + crypton-x509 >=1.10 && <1.11, + crypton-x509-store >=1.10 && <1.11, + crypton-x509-validation >=1.10 && <1.11, data-default, - ech-config, - hpke, - memory >= 0.18 && < 0.19, - mtl >= 2.2 && < 2.4, - network >= 3.1, - random >= 1.2 && < 1.4, - serialise >= 0.2 && < 0.3, - transformers >= 0.5 && < 0.7, - unix-time >= 0.4.11 && < 0.5, - zlib >= 0.7 && < 0.8 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover - hs-source-dirs: test - other-modules: - API - Arbitrary - Certificate - CiphersSpec - ECHSpec - EncodeSpec - HandshakeSpec - PipeChan - PubKey - Run - Session - ThreadSpec - - default-extensions: Strict StrictData - default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts - build-depends: - base >=4.9 && <5, - QuickCheck, - asn1-types, - async, - base64-bytestring, - bytestring, - crypton, - crypton-x509, - crypton-x509-validation, - ech-config, - hourglass, - hspec, - serialise, - tls + ech-config >=0.0.2, + hpke >=0.4.0 && <0.5, + mtl >=2.2 && <2.4, + network >=3.1, + ram >=0.22.0 && <0.23, + random >=1.2 && <1.4, + serialise >=0.2 && <0.3, + transformers >=0.5 && <0.7, + unix-time >=0.4.11 && <0.7, + zlib >=0.7 && <0.8 executable tls-server main-is: tls-server.hs @@ -190,8 +155,8 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, - bytestring, base16-bytestring, + bytestring, containers, crypton, crypton-x509-store, @@ -226,7 +191,7 @@ crypton-x509-system, ech-config, network, - network-run >= 0.5, + network-run >=0.6.0 && < 0.7, tls if flag(devel) @@ -234,13 +199,16 @@ else buildable: False -benchmark tls-bench - main-is: Benchmarks.hs - type: exitcode-stdio-1.0 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test other-modules: API Arbitrary Certificate + ChannelBindingSpec CiphersSpec ECHSpec EncodeSpec @@ -248,31 +216,27 @@ PipeChan PubKey Run + SecretSpec Session ThreadSpec - hs-source-dirs: - Benchmarks - test + default-language: Haskell2010 - ghc-options: -Wall + default-extensions: Strict StrictData + ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, - bytestring, - base64-bytestring, - containers, + QuickCheck, async, - data-default, - hourglass, + base64-bytestring, + bytestring, crypton, + crypton-asn1-types, crypton-x509, - crypton-x509-store, crypton-x509-validation, ech-config, - network, - network-run, - tls, - asn1-types, - tasty-bench, - QuickCheck, + hspec, + ram, serialise, - hspec + time-hourglass, + tls, + zlib diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -36,19 +36,27 @@ , ("ffdhe8192", ffdhe8192) ] +{- FOURMOLU_DISABLE -} namedGroups :: [(String, Group)] namedGroups = - [ ("ffdhe2048", FFDHE2048) - , ("ffdhe3072", FFDHE3072) - , ("ffdhe4096", FFDHE4096) - , ("ffdhe6144", FFDHE6144) - , ("ffdhe8192", FFDHE8192) - , ("p256", P256) - , ("p384", P384) - , ("p521", P521) - , ("x25519", X25519) - , ("x448", X448) + [ ("ffdhe2048", FFDHE2048) + , ("ffdhe3072", FFDHE3072) + , ("ffdhe4096", FFDHE4096) + , ("ffdhe6144", FFDHE6144) + , ("ffdhe8192", FFDHE8192) + , ("p256", P256) + , ("p384", P384) + , ("p521", P521) + , ("x25519", X25519) + , ("x448", X448) + , ("mlkem512", MLKEM512) + , ("mlkem768", MLKEM768) + , ("mlkem1024", MLKEM1024) + , ("x25519mlkem768", X25519MLKEM768) + , ("p256mlkem768", P256MLKEM768) + , ("p384mlkem1024", P384MLKEM1024) ] +{- FOURMOLU_ENABLE -} readNumber :: (Num a, Read a) => String -> Maybe a readNumber s @@ -103,7 +111,7 @@ minfo <- contextGetInformation ctx case minfo of Nothing -> do - putStrLn "Erro: information cannot be obtained" + putStrLn "Error: information cannot be obtained" exitFailure Just info -> return info 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 @@ -28,15 +31,18 @@ where body = "<Hello world!" +-- An HTTP request is answered with HTML, anything else is echoed. +-- tlsfuzzer's test-lengths.py sends "A..A\n", or just "\n", and expects +-- it back. server :: Context -> Bool -> IO () server ctx showRequest = do bs <- recvData ctx case C8.uncons bs of Nothing -> return () - Just ('A', _) -> do + Just ('G', _) -> handleHTML ctx showRequest bs + Just _ -> do sendData ctx $ CL8.fromStrict bs echo ctx - Just _ -> handleHTML ctx showRequest bs echo :: Context -> IO () echo ctx = loop @@ -47,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 @@ -74,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 @@ -84,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 diff --git a/util/tls-server.hs b/util/tls-server.hs --- a/util/tls-server.hs +++ b/util/tls-server.hs @@ -4,12 +4,16 @@ module Main where +import qualified Control.Exception as E import Data.IORef import qualified Data.Map.Strict as M import Data.X509.CertificateStore import Network.Run.TCP import Network.TLS import Network.TLS.ECH.Config +import Network.TLS.Extra.Cipher +import Network.TLS.Extra.CipherCBC +import Network.TLS.Extra.FFDHE import Network.TLS.Internal import System.Console.GetOpt import System.Environment (getArgs) @@ -27,12 +31,14 @@ , optShow :: Bool , optKeyLogFile :: Maybe FilePath , optTrustedAnchor :: Maybe FilePath - , optGroups :: [Group] + , optGroups :: Maybe [Group] , optCertFile :: FilePath , optKeyFile :: FilePath , optECHConfigFile :: Maybe FilePath , optECHKeyFile :: Maybe FilePath , optTraceKey :: Bool + , optUseWeakCiphers :: Bool + , optServerName :: Maybe HostName } deriving (Show) @@ -44,13 +50,14 @@ , optShow = False , optKeyLogFile = Nothing , optTrustedAnchor = Nothing - , -- excluding FFDHE8192 for retry - optGroups = FFDHE8192 `delete` supportedGroups defaultSupported + , optGroups = Nothing , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem" , optECHConfigFile = Nothing , optECHKeyFile = Nothing , optTraceKey = False + , optUseWeakCiphers = False + , optServerName = Nothing } options :: [OptDescr (Options -> Options)] @@ -78,7 +85,7 @@ , Option ['g'] ["groups"] - (ReqArg (\gs o -> o{optGroups = readGroups gs}) "") + (ReqArg (\gs o -> o{optGroups = Just $ readGroups gs}) "") "groups for key exchange" , Option ['c'] @@ -110,6 +117,16 @@ ["trace-key"] (NoArg (\o -> o{optTraceKey = True})) "Trace transcript hash" + , Option + [] + ["use-weak-ciphers"] + (NoArg (\o -> o{optUseWeakCiphers = True})) + "accept deprecated ciphers and relax checks (for tlsfuzzer)" + , Option + [] + ["server-name"] + (ReqArg (\n o -> o{optServerName = Just n}) "") + "refuse other names in SNI with unrecognized_name" ] usage :: String @@ -135,7 +152,16 @@ (host, port) <- case ips of [h, p] -> return (h, p) _ -> showUsageAndExit "cannot recognize and \n" - when (null optGroups) $ do + let groups = fromMaybe defaultGroups optGroups + defaultGroups + | optUseWeakCiphers = supportedGroups defaultSupported + -- excluding FFDHE8192 for retry + | otherwise = FFDHE8192 `delete` supportedGroups defaultSupported + -- A TLS 1.3 server picks a group from supportedGroupsTLS13, so the + -- groups given with -g go there too. Without -g, the default + -- preference stands. + groupsTLS13 = maybe (supportedGroupsTLS13 defaultSupported) (: []) optGroups + when (null groups) $ do putStrLn "Error: unsupported groups" exitFailure smgr <- newSessionManager @@ -169,7 +195,9 @@ let sparams = getServerParams creds - optGroups + optUseWeakCiphers + groups + groupsTLS13 smgr keyLog optClientAuth @@ -177,6 +205,7 @@ ech printError traceKey + optServerName ctx <- contextNew sock sparams when optDebugLog $ contextHookSetLogging @@ -196,7 +225,9 @@ getServerParams :: Credentials + -> Bool -> [Group] + -> [[Group]] -> SessionManager -> (String -> IO ()) -> Bool @@ -204,8 +235,9 @@ -> ([(Word8, ByteString)], ECHConfigList) -> (String -> IO ()) -> (String -> IO ()) + -> Maybe HostName -> ServerParams -getServerParams creds groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey = +getServerParams creds weak groups groupsTLS13 sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey mname = defaultParamsServer { serverSupported = supported , serverShared = shared @@ -214,6 +246,7 @@ , serverEarlyDataSize = 2048 , serverWantClientCert = clientAuth , serverECHKey = ekey + , serverDHEParams = if weak then Just ffdhe2048 else Nothing } where shared = @@ -231,15 +264,27 @@ } supported = defaultSupported - { supportedGroups = groups + { supportedCiphers = ciphers + , supportedGroups = groups + , supportedGroupsTLS13 = groupsTLS13 + , supportedExtendedMainSecret = + if weak then AllowEMS else supportedExtendedMainSecret defaultSupported + , supportedClientInitiatedRenegotiation = + weak || supportedClientInitiatedRenegotiation defaultSupported } + ciphers + | weak = ciphersuite_default ++ ciphersForFuzzer + | otherwise = ciphersuite_default hooks = defaultServerHooks - { onALPNClientSuggest = Just chooseALPN + { onALPNClientSuggest = Just $ chooseALPN weak , onClientCertificate = case mstore of Nothing -> onClientCertificate defaultServerHooks - Just _ -> - validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared) + Just _ + | weak -> acceptEmptyCertificate + | otherwise -> + validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared) + , onServerNameIndication = checkServerName mname } debug = defaultDebugParams @@ -247,12 +292,122 @@ , debugError = printError , debugTraceKey = traceKey } + acceptEmptyCertificate cc + | isNullCertificateChain cc = return CertificateUsageAccept + | otherwise = + validateClientCertificate + (sharedCAStore shared) + (sharedValidationCache shared) + cc -chooseALPN :: [ByteString] -> IO ByteString -chooseALPN protos - | "http/1.1" `elem` protos = return "http/1.1" - | otherwise = return "" +---------------------------------------------------------------- +-- Deprecated ciphers, accepted only with --use-weak-ciphers. +-- tlsfuzzer uses them in its TLS 1.2 tests. +ciphersForFuzzer :: [Cipher] +ciphersForFuzzer = + [ cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA + , cipher_DHE_RSA_WITH_AES_128_CBC_SHA + , cipher_RSA_WITH_AES_256_CBC_SHA + , cipher_RSA_WITH_AES_128_CBC_SHA + , cipher_RSA_WITH_AES_128_CBC_SHA256 + , cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 + , cipher_RSA_WITH_AES_128_GCM_SHA256 + , cipher_RSA_WITH_AES_256_GCM_SHA384 + , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + , cipher13_AES_128_CCM_8_SHA256 + ] + ++ ciphersuite_pfs_sha2_cbc + +-- CBC with HMAC-SHA1, derived from the SHA-2 ones in CipherCBC. +cipher_RSA_WITH_AES_128_CBC_SHA :: Cipher +cipher_RSA_WITH_AES_128_CBC_SHA = + cipher_DHE_RSA_AES128_SHA256 + { cipherID = 0x002F + , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA" + , cipherHash = SHA1 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } + +cipher_RSA_WITH_AES_256_CBC_SHA :: Cipher +cipher_RSA_WITH_AES_256_CBC_SHA = + cipher_DHE_RSA_AES256_SHA256 + { cipherID = 0x0035 + , cipherName = "TLS_RSA_WITH_AES_256_CBC_SHA" + , cipherHash = SHA1 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } + +-- tlsfuzzer's test-atypical-padding.py and test-lengths.py use this one +-- for an HMAC-SHA256 record. +cipher_RSA_WITH_AES_128_CBC_SHA256 :: Cipher +cipher_RSA_WITH_AES_128_CBC_SHA256 = + cipher_DHE_RSA_AES128_SHA256 + { cipherID = 0x003C + , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA256" + , cipherKeyExchange = CipherKeyExchange_RSA + } + +cipher_DHE_RSA_WITH_AES_128_CBC_SHA :: Cipher +cipher_DHE_RSA_WITH_AES_128_CBC_SHA = + cipher_RSA_WITH_AES_128_CBC_SHA + { cipherID = 0x0033 + , cipherName = "TLS_DHE_RSA_WITH_AES_128_CBC_SHA" + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Nothing + } + +cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA :: Cipher +cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA = + cipher_RSA_WITH_AES_128_CBC_SHA + { cipherID = 0xC013 + , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA" + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS10 + } + +-- AES-GCM with RSA key exchange, derived from the DHE ones. +cipher_RSA_WITH_AES_128_GCM_SHA256 :: Cipher +cipher_RSA_WITH_AES_128_GCM_SHA256 = + cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 + { cipherID = 0x009C + , cipherName = "TLS_RSA_WITH_AES_128_GCM_SHA256" + , cipherKeyExchange = CipherKeyExchange_RSA + } + +cipher_RSA_WITH_AES_256_GCM_SHA384 :: Cipher +cipher_RSA_WITH_AES_256_GCM_SHA384 = + cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 + { cipherID = 0x009D + , cipherName = "TLS_RSA_WITH_AES_256_GCM_SHA384" + , cipherKeyExchange = CipherKeyExchange_RSA + } + +-- Only HTTP/1.1 is spoken. With --use-weak-ciphers, the names +-- tlsfuzzer's test-alpn-negotiation.py switches to on renegotiation and +-- resumption are accepted too, in the client's order. +chooseALPN :: Bool -> [ByteString] -> IO ByteString +chooseALPN weak protos = return $ fromMaybe "" $ find (`elem` known) protos + where + known + | weak = ["http/1.1", "h2", "http/2"] + | otherwise = ["http/1.1"] + +-- RFC 6066 Section 3: a server that does not recognize the name may +-- abort with a fatal unrecognized_name, a warning one being NOT +-- RECOMMENDED. +checkServerName :: Maybe HostName -> Maybe HostName -> IO Credentials +checkServerName (Just name) (Just sni) + | sni /= name = + E.throwIO $ + Uncontextualized $ + Error_Protocol ("unrecognized name: " ++ sni) UnrecognizedName +checkServerName _ _ = return mempty + newSessionManager :: IO SessionManager newSessionManager = do ref <- newIORef M.empty @@ -262,9 +417,11 @@ M.lookup key <$> readIORef ref , sessionResumeOnlyOnce = \key -> do M.lookup key <$> readIORef ref - , sessionEstablish = \key val -> do - atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing) + , -- The session ID doubles as the ticket, so the table + -- serves resumption by either. + sessionEstablish = \key val -> do + atomicModifyIORef' ref $ \m -> (M.insert key val m, Just key) , sessionInvalidate = \key -> do atomicModifyIORef' ref $ \m -> (M.delete key m, ()) - , sessionUseTicket = False + , sessionUseTicket = True }