tls 2.3.1 → 2.5.1
raw patch · 71 files changed
Files
- Benchmarks/Benchmarks.hs +0/−187
- CHANGELOG.md +264/−4
- Network/TLS.hs +29/−10
- Network/TLS/Compression.hs +1/−1
- Network/TLS/Context.hs +52/−17
- Network/TLS/Context/Internal.hs +133/−11
- Network/TLS/Core.hs +218/−77
- Network/TLS/Credentials.hs +39/−17
- Network/TLS/Crypto.hs +96/−39
- Network/TLS/Crypto/IES.hs +116/−76
- Network/TLS/Error.hs +4/−5
- Network/TLS/Extension.hs +78/−43
- Network/TLS/Extra/Cipher.hs +65/−44
- Network/TLS/Extra/CipherCBC.hs +201/−0
- Network/TLS/Handshake/Certificate.hs +118/−15
- Network/TLS/Handshake/Client.hs +43/−26
- Network/TLS/Handshake/Client/ClientHello.hs +107/−91
- Network/TLS/Handshake/Client/Common.hs +51/−22
- Network/TLS/Handshake/Client/ServerHello.hs +63/−16
- Network/TLS/Handshake/Client/TLS12.hs +22/−2
- Network/TLS/Handshake/Client/TLS13.hs +100/−33
- Network/TLS/Handshake/Common.hs +74/−17
- Network/TLS/Handshake/Common13.hs +47/−40
- Network/TLS/Handshake/Control.hs +24/−0
- Network/TLS/Handshake/Key.hs +12/−0
- Network/TLS/Handshake/Server.hs +10/−7
- Network/TLS/Handshake/Server/ClientHello.hs +57/−7
- Network/TLS/Handshake/Server/ClientHello12.hs +77/−5
- Network/TLS/Handshake/Server/ClientHello13.hs +98/−47
- Network/TLS/Handshake/Server/Common.hs +45/−7
- Network/TLS/Handshake/Server/ServerHello12.hs +25/−6
- Network/TLS/Handshake/Server/ServerHello13.hs +23/−9
- Network/TLS/Handshake/Server/TLS12.hs +20/−4
- Network/TLS/Handshake/Server/TLS13.hs +169/−59
- Network/TLS/Handshake/Signature.hs +173/−85
- Network/TLS/Handshake/State.hs +27/−12
- Network/TLS/Handshake/State13.hs +11/−0
- Network/TLS/HashAndSignature.hs +0/−181
- Network/TLS/IO.hs +40/−19
- Network/TLS/IO/Decode.hs +64/−17
- Network/TLS/Internal.hs +2/−0
- Network/TLS/Packet.hs +61/−24
- Network/TLS/Packet13.hs +38/−11
- Network/TLS/Parameters.hs +131/−38
- Network/TLS/PostHandshake.hs +25/−4
- Network/TLS/QUIC.hs +3/−3
- Network/TLS/Record/Decrypt.hs +98/−27
- Network/TLS/Record/Recv.hs +39/−3
- Network/TLS/Session.hs +1/−0
- Network/TLS/SignatureScheme.hs +304/−0
- Network/TLS/State.hs +9/−0
- Network/TLS/Struct.hs +4/−4
- Network/TLS/Types.hs +17/−0
- Network/TLS/Types/Secret.hs +40/−5
- Network/TLS/Types/Session.hs +73/−2
- Network/TLS/Util.hs +1/−2
- Network/TLS/Wire.hs +7/−1
- test/Arbitrary.hs +22/−4
- test/Certificate.hs +23/−0
- test/ChannelBindingSpec.hs +297/−0
- test/CiphersSpec.hs +12/−0
- test/ECHSpec.hs +30/−5
- test/EncodeSpec.hs +307/−0
- test/HandshakeSpec.hs +4439/−1035
- test/PubKey.hs +26/−0
- test/Run.hs +52/−5
- test/SecretSpec.hs +65/−0
- tls.cabal +18/−55
- util/Common.hs +1/−1
- util/Server.hs +45/−13
- util/tls-server.hs +175/−18
− Benchmarks/Benchmarks.hs
@@ -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
CHANGELOG.md view
@@ -1,7 +1,267 @@ # Change log for "tls" -## Version 2.3.1+## 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)@@ -81,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.@@ -352,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`
Network/TLS.hs view
@@ -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 <params>@@ -25,6 +26,7 @@ handshake, sendData, recvData,+ closeNotifyReceived, bye, -- * Exceptions@@ -46,6 +48,7 @@ clientUseServerNameIndication, clientWantSessionResume, clientWantSessionResumeList,+ clientWantTicket, clientShared, clientHooks, clientSupported,@@ -102,6 +105,7 @@ onALPNClientSuggest, onEncryptedExtensionsCreating, onSelectKeyShare,+ onAccept0RTT, Measurement, nbHandshakes, bytesReceived,@@ -112,6 +116,12 @@ defaultSupported, supportedVersions, supportedCiphers,+ supportedMinRSAKeySize,+ supportedMaxRSAKeySize,+ supportedClientCertificatePurposes,+ supportedMinDHKeySize,+ supportedMaxDHKeySize,+ supportedClientCipherOrder, supportedCompressions, supportedHashSignatures, supportedSecureRenegotiation,@@ -138,7 +148,9 @@ Limit, defaultLimit, limitHandshakeFragment,+ limitKeyUpdate, limitRecordSize,+ limitRecordsPerKey, -- * Shared parameters @@ -164,6 +176,7 @@ -- ** Session data SessionData,+ defaultSessionData, sessionVersion, sessionCipher, sessionCompression,@@ -174,6 +187,8 @@ sessionALPN, sessionMaxEarlyDataSize, sessionFlags,+ sessionClientCertificate,+ sessionAppData, SessionFlag (..), TLS13TicketInfo, is0RTTPossible,@@ -192,10 +207,10 @@ Version (..), Compression (..), nullCompression,+ SignatureScheme (..), HashAndSignatureAlgorithm, supportedSignatureSchemes,- HashAlgorithm (..),- SignatureAlgorithm (..),+ signatureSchemesForTLS13, Group (..), supportedNamedGroups, EMSMode (..),@@ -233,6 +248,8 @@ infoTLS13HandshakeMode, infoIsEarlyDataAccepted, infoIsECHAccepted,+ infoServerSignatureScheme,+ infoClientSignatureScheme, ClientRandom, ServerRandom, unClientRandom,@@ -249,6 +266,8 @@ updateKey, KeyUpdateRequest (..), requestCertificate,+ requestCertificateAsync,+ PHAResult (..), getTLSUnique, getTLSExporter, getTLSServerEndPoint,@@ -297,6 +316,7 @@ -- ** Crypto Key PubKey (..), PrivKey (..),+ ExtKeyUsagePurpose (..), -- ** Ciphers & Predefined ciphers module Network.TLS.Cipher,@@ -309,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 (..))@@ -341,14 +361,14 @@ CertificateType (..), ClientRandom (..), Handshake,- HashAlgorithm (..),+ SignatureScheme (..), HashAndSignatureAlgorithm, Header (..), ProtocolType (..), ServerRandom (..),- SignatureAlgorithm (..), TLSError (..), TLSException (..),+ signatureSchemesForTLS13, supportedSignatureSchemes, ) import Network.TLS.Struct13 (Handshake13)@@ -359,10 +379,9 @@ type Bytes = ByteString -- | Getting certificates from a client, if any.--- Note that the certificates are not sent by a client--- on resumption even if client authentication is required.--- So, this API would be replaced by the one which can treat--- both cases of full-negotiation and resumption.+-- A client sends no certificate on resumption; then this returns the+-- leaf certificate it was authenticated with in the original connection.+-- That chain was validated then and is not checked again. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain
Network/TLS/Compression.hs view
@@ -51,7 +51,7 @@ (==) c1 c2 = compressionID c1 == compressionID c2 -- | intersect a list of ids commonly given by the other side with a list of compression--- the function keeps the list of compression in order, to be able to find quickly the prefered+-- the function keeps the list of compression in order, to be able to find quickly the preferred -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l
Network/TLS/Context.hs view
@@ -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@@ -114,7 +118,8 @@ doHandshake :: a -> Context -> 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
Network/TLS/Context/Internal.hs view
@@ -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,7 +94,7 @@ ) 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@@ -111,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@@ -126,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@@ -141,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@@ -170,7 +183,8 @@ { doHandshake_ :: Context -> 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@@ -199,11 +213,14 @@ 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@@ -211,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@@ -234,6 +276,8 @@ , tls13stHsKey = Nothing , tls13stSession = Session Nothing , tls13stSentExtensions = []+ , tls13stPHA = Nothing+ , tls13stPHAResponding = False } getTLS13State :: Context -> IO TLS13State@@ -242,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 ())@@ -266,11 +320,20 @@ 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. PendingRecvAction Bool (Handshake13 -> IO ())@@ -292,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 @@ -300,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@@ -310,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@@ -335,6 +407,8 @@ , infoTLS13HandshakeMode = hm13 , infoIsEarlyDataAccepted = accepted , infoIsECHAccepted = ech+ , infoServerSignatureScheme = ssig+ , infoClientSignatureScheme = csig } _ -> return Nothing @@ -349,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 @@ -363,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@@ -387,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)@@ -449,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)
Network/TLS/Core.hs view
@@ -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,8 +298,10 @@ 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{}] [b]) = handshakeWith ctx (ch, b) >> recvData12 ctx@@ -219,7 +310,7 @@ -- 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@@ -264,8 +372,9 @@ loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data.- process (AppData13 "") = recvData13 ctx+ process (AppData13 "") = checkPHAResponse >> recvData13 ctx process (AppData13 x) = do+ checkPHAResponse let chunkLen = C8.length x established <- ctxEstablished ctx case established of@@ -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@@ -330,14 +432,18 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hbs loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do- let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs- when multipleKeyUpdate $ do- let reason = "Multiple KeyUpdate is not allowed in one record"- terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ checkPHAResponse when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- checkAlignment ctx+ 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+ 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{}, _b) : hbs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hbs- loopHandshake13 (hb@(h, _) : hbs) = 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 hb- when cont $ loopHandshake13 hbs+ popAction ctx hb hbs+ loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do@@ -378,8 +497,9 @@ 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 (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@@ -417,50 +537,63 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hbs loopHandshake13 (hb : hbs) = do- cont <- popAction ctx hb- when cont $ loopHandshake13 hbs+ popAction ctx hb hbs+ loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13R -> IO Bool-popAction ctx hb@(h, _b) = 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 pa -> do- when needAligned $ checkAlignment ctx- updateTranscriptHash13 ctx hb- pa h- PendingRecvActionSelfUpdate needAligned pa -> do- when needAligned $ checkAlignment ctx- pa hb- PendingRecvActionHash needAligned pa -> do- when needAligned $ checkAlignment ctx- 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- 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 -> IO ()-checkAlignment ctx = 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 ()@@ -504,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" #-}
Network/TLS/Credentials.hs view
@@ -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
Network/TLS/Crypto.hs view
@@ -54,11 +54,12 @@ import qualified Crypto.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.MLDSA as MLDSA import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random-import Data.ASN1.BinaryEncoding (BER (..), DER (..))+import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert)@@ -71,6 +72,7 @@ PubKey (..), PubKeyEC (..), SerializedPoint (..),+ privkeyMLDSA_key, ) import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint) @@ -261,6 +263,13 @@ | ECDSAParams Hash | Ed25519Params | Ed448Params+ | -- | Pure ML-DSA with an empty context, which is what+ -- draft-ietf-tls-mldsa uses. One constructor per parameter set,+ -- since the key fixes it and a signature made under one does not+ -- verify under another.+ MLDSA44Params+ | MLDSA65Params+ | MLDSA87Params deriving (Show, Eq) -- Verify that the signature matches the given message, using the@@ -271,38 +280,21 @@ kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign kxVerify (PubKeyDSA pk) DSAParams msg signBS =- case dsaToSignature signBS of- Just sig -> DSA.verify H.SHA1 pk sig msg+ case decodeSignatureRS signBS of+ Just (r, s) -> DSA.verify H.SHA1 pk DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} msg _ -> False- where- dsaToSignature :: ByteString -> Maybe DSA.Signature- dsaToSignature b =- case decodeASN1' BER b of- Left _ -> Nothing- Right asn1 ->- case asn1 of- Start Sequence : IntVal r : IntVal s : End Sequence : _ ->- Just DSA.Signature{DSA.sign_r = r, DSA.sign_s = s}- _ ->- Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ join $ withPubKeyEC key verifyProxy verifyClassic Nothing where- decodeSignatureASN1 buildRS =- case decodeASN1' BER sigBS of- Left _ -> Nothing- Right [Start Sequence, IntVal r, IntVal s, End Sequence] ->- Just (buildRS r s)- Right _ -> Nothing verifyProxy prx pubkey = do- rs <- decodeSignatureASN1 (,)+ rs <- decodeSignatureRS sigBS signature <- maybeCryptoError $ ECDSA.signatureFromIntegers prx rs verifyF <- withAlg (ECDSA.verify prx) return $ verifyF pubkey signature msg verifyClassic pubkey = do- signature <- decodeSignatureASN1 ECDSA_ECC.Signature+ signature <- uncurry ECDSA_ECC.Signature <$> decodeSignatureRS sigBS verifyF <- withAlg ECDSA_ECC.verify return $ verifyF pubkey signature msg withAlg :: (forall hash. H.HashAlgorithm hash => hash -> a) -> Maybe a@@ -322,8 +314,66 @@ case Ed448.signature sigBS of CryptoPassed sig -> Ed448.verify key msg sig _ -> False+-- A signature of the wrong length is refused by the smart constructor, and+-- one of the right length that does not verify returns False. Neither+-- throws, which is what a peer sending a damaged CertificateVerify has to+-- meet with decrypt_error rather than with a crash.+kxVerify (PubKeyMLDSA44 key) MLDSA44Params msg sigBS = mldsaVerify key msg sigBS+kxVerify (PubKeyMLDSA65 key) MLDSA65Params msg sigBS = mldsaVerify key msg sigBS+kxVerify (PubKeyMLDSA87 key) MLDSA87Params msg sigBS = mldsaVerify key msg sigBS kxVerify _ _ _ _ = False +mldsaVerify+ :: MLDSA.MLDSA p+ => MLDSA.VerificationKey p -> ByteString -> ByteString -> Bool+mldsaVerify key msg sigBS = case MLDSA.signature sigBS of+ CryptoPassed sig -> MLDSA.verify key MLDSA.emptyContext msg sig+ _ -> False++-- | Decode a DSA or ECDSA signature: a DER SEQUENCE of two INTEGERs, r+-- and s (RFC 3279 Sections 2.2.2 and 2.2.3). This is done here rather+-- than with crypton-asn1-encoding, whose 'decodeASN1'' throws on some+-- malformed input rather than returning 'Left'. Only DER is accepted:+-- definite lengths in their shortest form, non-negative INTEGERs in+-- theirs, and nothing after the SEQUENCE.+decodeSignatureRS :: ByteString -> Maybe (Integer, Integer)+decodeSignatureRS bs = do+ (0x30, body) <- whole bs+ (0x02, rbs, rest) <- tlv body+ (0x02, sbs) <- whole rest+ (,) <$> derInteger rbs <*> derInteger sbs+ where+ whole b = do+ (t, v, rest) <- tlv b+ guard $ B.null rest+ return (t, v)+ tlv b = do+ (t, b1) <- B.uncons b+ (l0, b2) <- B.uncons b1+ (len, b3) <- case l0 of+ _ | l0 < 0x80 -> Just (fromIntegral l0, b2)+ 0x81 -> do+ (l1, b3) <- B.uncons b2+ guard $ l1 >= 0x80+ Just (fromIntegral l1, b3)+ 0x82 -> do+ (l1, b3) <- B.uncons b2+ (l2, b4) <- B.uncons b3+ let n = fromIntegral l1 * 256 + fromIntegral l2 :: Int+ guard $ n >= 0x100+ Just (n, b4)+ _ -> Nothing+ guard $ B.length b3 >= len+ let (v, rest) = B.splitAt len b3+ return (t, v, rest)+ derInteger v = do+ (h, t) <- B.uncons v+ guard $ h < 0x80+ case B.uncons t of+ Just (h2, _) | h == 0 -> guard $ h2 >= 0x80+ _ -> return ()+ return $ B.foldl' (\acc w -> acc * 256 + fromIntegral w) 0 v+ -- Sign the given message using the private key. -- kxSign@@ -366,6 +416,12 @@ return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg = return $ Right $ convert $ Ed448.sign pk pub msg+kxSign (PrivKeyMLDSA44 pk) (PubKeyMLDSA44 _) MLDSA44Params msg =+ Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg+kxSign (PrivKeyMLDSA65 pk) (PubKeyMLDSA65 _) MLDSA65Params msg =+ Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg+kxSign (PrivKeyMLDSA87 pk) (PubKeyMLDSA87 _) MLDSA87Params msg =+ Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg kxSign _ _ _ _ = return (Left KxUnsupported) @@ -375,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@@ -395,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)
Network/TLS/Crypto/IES.hs view
@@ -34,8 +34,8 @@ import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..)) import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES-import Crypto.PubKey.ML_KEM (ML_KEM_1024, ML_KEM_512, ML_KEM_768)-import qualified Crypto.PubKey.ML_KEM as ML+import Crypto.PubKey.MLKEM (MLKEM1024, MLKEM512, MLKEM768)+import qualified Crypto.PubKey.MLKEM as ML import Data.ByteArray (ScrubbedBytes, convert) import qualified Data.ByteArray as BA import Data.Proxy@@ -58,12 +58,12 @@ | GroupPri_FFDHE4096 PrivateNumber | GroupPri_FFDHE6144 PrivateNumber | GroupPri_FFDHE8192 PrivateNumber- | GroupPri_MLKEM512 (ML.DecapsulationKey ML_KEM_512)- | GroupPri_MLKEM768 (ML.DecapsulationKey ML_KEM_768)- | GroupPri_MLKEM1024 (ML.DecapsulationKey ML_KEM_1024)- | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey ML_KEM_768)- | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey ML_KEM_768)- | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey ML_KEM_1024)+ | GroupPri_MLKEM512 (ML.DecapsulationKey MLKEM512)+ | GroupPri_MLKEM768 (ML.DecapsulationKey MLKEM768)+ | GroupPri_MLKEM1024 (ML.DecapsulationKey MLKEM1024)+ | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey MLKEM768)+ | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey MLKEM768)+ | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey MLKEM1024) deriving (Eq, Show) {- FOURMOLU_ENABLE -} @@ -79,12 +79,12 @@ | GroupPubA_FFDHE4096 PublicNumber | GroupPubA_FFDHE6144 PublicNumber | GroupPubA_FFDHE8192 PublicNumber- | GroupPubA_MLKEM512 (ML.EncapsulationKey ML_KEM_512)- | GroupPubA_MLKEM768 (ML.EncapsulationKey ML_KEM_768)- | GroupPubA_MLKEM1024 (ML.EncapsulationKey ML_KEM_1024)- | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey ML_KEM_768)- | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey ML_KEM_768)- | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey ML_KEM_1024)+ | GroupPubA_MLKEM512 (ML.EncapsulationKey MLKEM512)+ | GroupPubA_MLKEM768 (ML.EncapsulationKey MLKEM768)+ | GroupPubA_MLKEM1024 (ML.EncapsulationKey MLKEM1024)+ | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey MLKEM768)+ | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey MLKEM768)+ | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey MLKEM1024) deriving (Eq, Show) {- FOURMOLU_ENABLE -} @@ -100,12 +100,12 @@ | GroupPubB_FFDHE4096 PublicNumber | GroupPubB_FFDHE6144 PublicNumber | GroupPubB_FFDHE8192 PublicNumber- | GroupPubB_MLKEM512 (ML.Ciphertext ML_KEM_512)- | GroupPubB_MLKEM768 (ML.Ciphertext ML_KEM_768)- | GroupPubB_MLKEM1024 (ML.Ciphertext ML_KEM_1024)- | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext ML_KEM_768)- | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext ML_KEM_768)- | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext ML_KEM_1024)+ | GroupPubB_MLKEM512 (ML.Ciphertext MLKEM512)+ | GroupPubB_MLKEM768 (ML.Ciphertext MLKEM768)+ | GroupPubB_MLKEM1024 (ML.Ciphertext MLKEM1024)+ | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext MLKEM768)+ | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext MLKEM768)+ | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext MLKEM1024) deriving (Eq, Show) {- FOURMOLU_ENABLE -} @@ -126,13 +126,27 @@ x448 :: Proxy Curve_X448 x448 = Proxy -mlkem512 :: Proxy ML_KEM_512+mlkem512 :: Proxy MLKEM512 mlkem512 = Proxy -mlkem768 :: Proxy ML_KEM_768+-- crypton reports a value it will not accept as a 'CryptoFailable' and has a+-- constructor per type rather than one overloaded 'decode'. These two keep+-- the call sites below in the shape they were.+--+-- 'ML.encapsulationKey' is the stricter of the two: besides the length it+-- runs the check of FIPS 203 section 7.2, so an encapsulation key whose+-- coefficients are out of range is refused here rather than used.+decodeEK+ :: ML.MLKEM p => proxy p -> ByteString -> Maybe (ML.EncapsulationKey p)+decodeEK _ = maybeCryptoError . ML.encapsulationKey++decodeCT :: ML.MLKEM p => proxy p -> ByteString -> Maybe (ML.Ciphertext p)+decodeCT _ = maybeCryptoError . ML.ciphertext++mlkem768 :: Proxy MLKEM768 mlkem768 = Proxy -mlkem1024 :: Proxy ML_KEM_1024+mlkem1024 :: Proxy MLKEM1024 mlkem1024 = Proxy dhParamsForGroup :: Group -> Maybe DH.Params@@ -160,25 +174,25 @@ groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPubA_FFDHE6144 groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPubA_FFDHE8192 groupGenerateKeyPair MLKEM512 = do- (e, d) <- ML.generate mlkem512+ (e, d) <- ML.generateKeyPair mlkem512 return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e) groupGenerateKeyPair MLKEM768 = do- (e, d) <- ML.generate mlkem768+ (e, d) <- ML.generateKeyPair mlkem768 return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e) groupGenerateKeyPair MLKEM1024 = do- (e, d) <- ML.generate mlkem1024+ (e, d) <- ML.generateKeyPair mlkem1024 return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e) groupGenerateKeyPair X25519MLKEM768 = do (d1, e1) <- fs' $ curveGenerateKeyPair x25519- (e2, d2) <- ML.generate mlkem768+ (e2, d2) <- ML.generateKeyPair mlkem768 return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2)) groupGenerateKeyPair P256MLKEM768 = do (d1, e1) <- fs' $ curveGenerateKeyPair p256- (e2, d2) <- ML.generate mlkem768+ (e2, d2) <- ML.generateKeyPair mlkem768 return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2)) groupGenerateKeyPair P384MLKEM1024 = do (d1, e1) <- fs' $ curveGenerateKeyPair p384- (e2, d2) <- ML.generate mlkem1024+ (e2, d2) <- ML.generateKeyPair mlkem1024 return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair" @@ -228,6 +242,17 @@ -> r (PrivateNumber, PublicNumber) gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits +-- 'ML.encapsulate' takes the parameter set as a proxy and reports a+-- failure, as every KEM in Crypto.KEM does; ML-KEM has none to report.+mlkemEncap+ :: (MonadRandom r, ML.MLKEM p)+ => proxy p+ -> ML.EncapsulationKey p+ -> r (Maybe (ML.Ciphertext p, GroupKey))+mlkemEncap p ek = fmap f <$> fmap maybeCryptoError (ML.encapsulate p ek)+ where+ f (ct, sec) = (ct, convert sec)+ groupEncapsulate :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey)) groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub@@ -240,30 +265,45 @@ groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096 groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144 groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192-groupEncapsulate (GroupPubA_MLKEM512 pub) = do- (sec, ct) <- ML.encapsulate pub- return $ Just (GroupPubB_MLKEM512 ct, convert sec)-groupEncapsulate (GroupPubA_MLKEM768 pub) = do- (sec, ct) <- ML.encapsulate pub- return $ Just (GroupPubB_MLKEM768 ct, convert sec)-groupEncapsulate (GroupPubA_MLKEM1024 pub) = do- (sec, ct) <- ML.encapsulate pub- return $ Just (GroupPubB_MLKEM1024 ct, convert sec)-groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = do- (c1, k1) <- fromJust <$> getECDHPubShared' x25519 e1- (k2, c2) <- ML.encapsulate e2- -- Sec 4.1: Specifically, the order of shares in the concatenation- -- has been reversed.- return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1)-groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = do- (c1, k1) <- fromJust <$> getECDHPubShared' p256 e1- (k2, c2) <- ML.encapsulate e2- return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)-groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do- (c1, k1) <- fromJust <$> getECDHPubShared' p384 e1- (k2, c2) <- ML.encapsulate e2- return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2)+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, GroupKey)) dhGroupGetPubShared FFDHE2048 pub = getDHPubShared' ffdhe2048 exp2048 pub@@ -339,22 +379,22 @@ groupDecapsulate (GroupPubB_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcDHShared ffdhe6144 pub pri groupDecapsulate (GroupPubB_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcDHShared ffdhe8192 pub pri groupDecapsulate (GroupPubB_MLKEM512 p) (GroupPri_MLKEM512 s) =- Just $ convert $ ML.decapsulate s p+ convert <$> maybeCryptoError (ML.decapsulate mlkem512 s p) groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) =- Just $ convert $ ML.decapsulate s p+ convert <$> maybeCryptoError (ML.decapsulate mlkem768 s p) groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) =- Just $ convert $ ML.decapsulate s p+ convert <$> maybeCryptoError (ML.decapsulate mlkem1024 s p) groupDecapsulate (GroupPubB_X25519MLKEM768 (p1, p2)) (GroupPri_X25519MLKEM768 (s1, s2)) = do bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 p1 s1- let bs2 = convert $ ML.decapsulate s2 p2+ bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem768 s2 p2) return (bs2 <> bs1) groupDecapsulate (GroupPubB_P256MLKEM768 (p1, p2)) (GroupPri_P256MLKEM768 (s1, s2)) = do bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 p1 s1- let bs2 = convert $ ML.decapsulate s2 p2+ bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem768 s2 p2) return (bs1 <> bs2) groupDecapsulate (GroupPubB_P384MLKEM1024 (p1, p2)) (GroupPri_P384MLKEM1024 (s1, s2)) = do bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 p1 s1- let bs2 = convert $ ML.decapsulate s2 p2+ bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem1024 s2 p2) return (bs1 <> bs2) groupDecapsulate _ _ = Nothing @@ -376,15 +416,15 @@ groupEncodePublicA (GroupPubA_FFDHE4096 p) = enc ffdhe4096 p groupEncodePublicA (GroupPubA_FFDHE6144 p) = enc ffdhe6144 p groupEncodePublicA (GroupPubA_FFDHE8192 p) = enc ffdhe8192 p-groupEncodePublicA (GroupPubA_MLKEM512 p) = ML.encode p-groupEncodePublicA (GroupPubA_MLKEM768 p) = ML.encode p-groupEncodePublicA (GroupPubA_MLKEM1024 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM512 p) = BA.convert p+groupEncodePublicA (GroupPubA_MLKEM768 p) = BA.convert p+groupEncodePublicA (GroupPubA_MLKEM1024 p) = BA.convert p groupEncodePublicA (GroupPubA_X25519MLKEM768 (p1, p2)) =- ML.encode p2 <> encodePoint x25519 p1+ BA.convert p2 <> encodePoint x25519 p1 groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) =- encodePoint p256 p1 <> ML.encode p2+ encodePoint p256 p1 <> BA.convert p2 groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) =- encodePoint p384 p1 <> ML.encode p2+ encodePoint p384 p1 <> BA.convert p2 groupEncodePublicB :: GroupPublicB -> ByteString groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p@@ -421,32 +461,32 @@ groupDecodePublicA FFDHE4096 bs = Right . GroupPubA_FFDHE4096 . PublicNumber $ os2ip bs groupDecodePublicA FFDHE6144 bs = Right . GroupPubA_FFDHE6144 . PublicNumber $ os2ip bs groupDecodePublicA FFDHE8192 bs = Right . GroupPubA_FFDHE8192 . PublicNumber $ os2ip bs-groupDecodePublicA MLKEM512 bs = case ML.decode mlkem512 bs of+groupDecodePublicA MLKEM512 bs = case decodeEK mlkem512 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubA_MLKEM512 p-groupDecodePublicA MLKEM768 bs = case ML.decode mlkem768 bs of+groupDecodePublicA MLKEM768 bs = case decodeEK mlkem768 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubA_MLKEM768 p-groupDecodePublicA MLKEM1024 bs = case ML.decode mlkem1024 bs of+groupDecodePublicA MLKEM1024 bs = case decodeEK mlkem1024 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubA_MLKEM1024 p groupDecodePublicA X25519MLKEM768 bs = let (bs1, bs2) = BA.splitAt 1184 bs- in case ML.decode mlkem768 bs1 of+ in case decodeEK mlkem768 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubA_X25519MLKEM768 (p2, p1) groupDecodePublicA P256MLKEM768 bs = let (bs1, bs2) = BA.splitAt 65 bs- in case ML.decode mlkem768 bs2 of+ in case decodeEK mlkem768 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubA_P256MLKEM768 (p2, p1) groupDecodePublicA P384MLKEM1024 bs = let (bs1, bs2) = BA.splitAt 97 bs- in case ML.decode mlkem1024 bs2 of+ in case decodeEK mlkem1024 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of Nothing -> Left CryptoError_PointFormatInvalid@@ -464,32 +504,32 @@ groupDecodePublicB FFDHE4096 bs = Right . GroupPubB_FFDHE4096 . PublicNumber $ os2ip bs groupDecodePublicB FFDHE6144 bs = Right . GroupPubB_FFDHE6144 . PublicNumber $ os2ip bs groupDecodePublicB FFDHE8192 bs = Right . GroupPubB_FFDHE8192 . PublicNumber $ os2ip bs-groupDecodePublicB MLKEM512 bs = case ML.decode mlkem512 bs of+groupDecodePublicB MLKEM512 bs = case decodeCT mlkem512 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubB_MLKEM512 p-groupDecodePublicB MLKEM768 bs = case ML.decode mlkem768 bs of+groupDecodePublicB MLKEM768 bs = case decodeCT mlkem768 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubB_MLKEM768 p-groupDecodePublicB MLKEM1024 bs = case ML.decode mlkem1024 bs of+groupDecodePublicB MLKEM1024 bs = case decodeCT mlkem1024 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubB_MLKEM1024 p groupDecodePublicB X25519MLKEM768 bs = let (bs1, bs2) = BA.splitAt 1088 bs- in case ML.decode mlkem768 bs1 of+ in case decodeCT mlkem768 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubB_X25519MLKEM768 (p2, p1) groupDecodePublicB P256MLKEM768 bs = let (bs1, bs2) = BA.splitAt 65 bs- in case ML.decode mlkem768 bs2 of+ in case decodeCT mlkem768 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubB_P256MLKEM768 (p2, p1) groupDecodePublicB P384MLKEM1024 bs = let (bs1, bs2) = BA.splitAt 97 bs- in case ML.decode mlkem1024 bs2 of+ in case decodeCT mlkem1024 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of Nothing -> Left CryptoError_PointFormatInvalid
Network/TLS/Error.hs view
@@ -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 ----------------------------------------------------------------
Network/TLS/Extension.hs view
@@ -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
Network/TLS/Extra/Cipher.hs view
@@ -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) ----------------------------------------------------------------
+ Network/TLS/Extra/CipherCBC.hs view
@@ -0,0 +1,201 @@+module Network.TLS.Extra.CipherCBC (+ -- * TLS 1.2 CBC ciphers with PFS and SHA2+ ciphersuite_pfs_sha2_cbc,+ ciphersuite_ecdhe_sha2_cbc,+ ciphersuite_dhe_rsa_sha2_cbc,++ -- ** Individual CBC ciphers+ cipher_DHE_RSA_AES128_SHA256,+ cipher_DHE_RSA_AES256_SHA256,+ cipher_ECDHE_RSA_AES128CBC_SHA256,+ cipher_ECDHE_RSA_AES256CBC_SHA384,+ cipher_ECDHE_ECDSA_AES128CBC_SHA256,+) where++import Crypto.Cipher.AES+import Crypto.Cipher.Types hiding (Cipher, cipherName)+import Crypto.Error+-- import Crypto.System.CPU+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types hiding (IV)++----------------------------------------------------------------++-- | TLS 1.2 AES CBC ciphers with DHE or ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_pfs_sha2_cbc :: [Cipher]+ciphersuite_pfs_sha2_cbc =+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+ , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_DHE_RSA_AES128_SHA256+ , cipher_DHE_RSA_AES256_SHA256+ ]++-- | TLS 1.2 AES CBC ciphers with ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_ecdhe_sha2_cbc :: [Cipher]+ciphersuite_ecdhe_sha2_cbc =+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+ , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ ]++-- | TLS 1.2 AES CBC ciphers with DHE key exchange, RSA authentication and a+-- SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_dhe_rsa_sha2_cbc :: [Cipher]+ciphersuite_dhe_rsa_sha2_cbc =+ [ cipher_DHE_RSA_AES256_SHA256+ , cipher_DHE_RSA_AES128_SHA256+ ]++----------------------------------------------------------------++-- | TLS 1.2 AES128 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES128_SHA256 :: Cipher+cipher_DHE_RSA_AES128_SHA256 =+ Cipher+ { cipherID = 0x0067+ , cipherName = "DHE-RSA-AES128-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES256 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES256_SHA256 :: Cipher+cipher_DHE_RSA_AES256_SHA256 =+ cipher_DHE_RSA_AES128_SHA256+ { cipherID = 0x006B+ , cipherName = "DHE-RSA-AES256-SHA256"+ , cipherBulk = bulk_aes256+ }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_RSA_AES128CBC_SHA256 =+ Cipher+ { cipherID = 0xC027+ , cipherName = "ECDHE-RSA-AES128CBC-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, RSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_RSA_AES256CBC_SHA384 =+ Cipher+ { cipherID = 0xC028+ , cipherName = "ECDHE-RSA-AES256CBC-SHA384"+ , cipherBulk = bulk_aes256+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, ECDSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CBC_SHA256 =+ Cipher+ { cipherID = 0xc023+ , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, ECDSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_ECDSA_AES256CBC_SHA384 =+ Cipher+ { cipherID = 0xC024+ , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384"+ , cipherBulk = bulk_aes256+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++----------------------------------------------------------------++aes128cbc :: BulkDirection -> BulkKey -> BulkBlock+aes128cbc BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \iv input ->+ let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+ )+aes128cbc BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \iv input ->+ let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+ )++aes256cbc :: BulkDirection -> BulkKey -> BulkBlock+aes256cbc BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \iv input ->+ let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+ )+aes256cbc BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \iv input ->+ let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+ )++makeIV_ :: BlockCipher a => B.ByteString -> IV a+makeIV_ = fromMaybe (error "makeIV_") . makeIV++takelast :: Int -> B.ByteString -> B.ByteString+takelast i b = B.drop (B.length b - i) b++noFail :: CryptoFailable a -> a+noFail = throwCryptoError++----------------------------------------------------------------++bulk_aes128 :: Bulk+bulk_aes128 =+ Bulk+ { bulkName = "AES128"+ , bulkKeySize = 16+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF aes128cbc+ }++bulk_aes256 :: Bulk+bulk_aes256 =+ Bulk+ { bulkName = "AES256"+ , bulkKeySize = 32+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF aes256cbc+ }
Network/TLS/Handshake/Certificate.hs view
@@ -3,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
Network/TLS/Handshake/Client.hs view
@@ -102,7 +102,7 @@ case ver of TLS13 | hrr ->- helloRetry cparams ctx mparams ver crand (grpsSupported \\ grpsSelected)+ helloRetry cparams ctx mparams ver crand grpsSupported grpsSelected | otherwise -> do recvServerSecondFlight13 cparams ctx grpsSelected sendClientSecondFlight13 cparams ctx@@ -126,8 +126,9 @@ -> Version -> ClientRandom -> [Group]+ -> [Group] -> IO ()-helloRetry cparams ctx mparams ver crand groupsSupported = do+helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do when (null groupsSupported) $ throwCore $ Error_Protocol "no supported groups on the client side" IllegalParameter@@ -137,31 +138,47 @@ mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup)- | selectedGroup `elem` groupsSupported -> do- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- clearTxRecordState ctx- let cparams' = cparams{clientUseEarlyData = False}- runPacketFlight ctx $ sendChangeCipherSpec13 ctx- clientSession <- tls13stSession <$> getTLS13State ctx- let groupsSupported' = selectedGroup : filter (/= selectedGroup) groupsSupported- groupsSelected' = [selectedGroup]- grps =- Groups- { grpsSupported = groupsSupported'- , grpsSelected = groupsSelected'- }-- handshake- cparams'- ctx- grps- (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))
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -104,10 +104,7 @@ -> Context -> Groups -> ClientRandom- -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32)- , Maybe CipherChoice- , Bool- )+ -> PreSharedKeyInfo -> IO () sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer@@ -215,13 +212,16 @@ -------------------- + -- 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 -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond -- to a group offered in the "supported_groups" extension and MUST@@ -262,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)@@ -302,9 +304,18 @@ keyShareExt | tls13 = do- (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected- usingHState ctx $ setGroupPrivate grpCpris- return $ Just $ toExtensionRaw $ KeyShareClientHello ents+ 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 =@@ -319,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) $ convert 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 $ BA.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@@ -385,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 )@@ -396,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@@ -405,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 ---------------------------------------------------------------- @@ -506,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 []@@ -526,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@@ -539,7 +556,6 @@ where mpkR = cnfEncodedPublicKey conf kemid = cnfKemId conf- nT = nTag aeadid ----------------------------------------------------------------
Network/TLS/Handshake/Client/Common.hs view
@@ -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
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -4,6 +4,7 @@ module Network.TLS.Handshake.Client.ServerHello ( receiveServerHello, processServerHello13,+ processRecordSizeLimit, ) where import Data.ByteArray (convert)@@ -21,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@@ -52,10 +52,13 @@ -- False otherwise. For 2nd server hello, getTLS13HR returns -- False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR+ -- 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@@ -89,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@@ -120,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@@ -138,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) $@@ -150,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@@ -173,9 +217,8 @@ then do -- Session is dummy in TLS 1.3. usingState_ ctx $ setSession shSession- processRecordSizeLimit ctx shExtensions True- enableMyRecordLimit ctx- enablePeerRecordLimit ctx+ -- RecordSizeLimit comes in EncryptedExtensions in TLS 1.3+ -- (RFC 8449 Section 4), and is processed there. let usedHash = cipherHash usedCipher transitTranscriptHashI ctx "transitI" usedHash isHRR accepted <- checkECHacceptance ctx isHRR usedHash sh@@ -266,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
Network/TLS/Handshake/Client/TLS12.hs view
@@ -49,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@@ -205,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
Network/TLS/Handshake/Client/TLS13.hs view
@@ -7,7 +7,7 @@ postHandshakeAuthClientWith, ) where -import Control.Exception (bracket)+import qualified Control.Exception as E import Control.Monad.State.Strict import qualified Data.ByteArray as BA import Data.IORef@@ -110,43 +110,75 @@ 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 (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+ 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+ Nothing -> usingHState ctx $ setTLS13RTT0Status RTT0Rejected expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ----------------------------------------------------------------@@ -206,7 +238,7 @@ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure unsighash :: SignatureAlgorithms- -> Maybe [HashAndSignatureAlgorithm]+ -> Maybe [SignatureScheme] unsighash (SignatureAlgorithms a) = Just a ----------------------------------------------------------------@@ -222,13 +254,19 @@ :: 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 ---------------------------------------------------------------- @@ -331,7 +369,7 @@ {- Unused for now uncertsig :: SignatureAlgorithmsCert- -> Maybe [HashAndSignatureAlgorithm]+ -> Maybe [SignatureScheme] uncertsig (SignatureAlgorithmsCert a) = Just a -} @@ -377,10 +415,13 @@ ---------------------------------------------------------------- postHandshakeAuthClientWith- :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) =- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- -- updateTranscriptHash13 ctx h b+ :: 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) $@@ -407,16 +448,42 @@ asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx- [ PendingRecvActionSelfUpdate True expectServerHello- , PendingRecvAction True (expectEncryptedExtensions ctx)- , PendingRecvActionHash True expectFinishedAndSet- ]+ [PendingRecvActionSelfUpdate True expectServerHello] where expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh updateTranscriptHash13 ctx shb -- update by myself- void $ prepareSecondFlight13 ctx groupSent+ 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 $
Network/TLS/Handshake/Common.hs view
@@ -17,10 +17,13 @@ runRecvState, runRecvStateHS, recvPacketHandshake,+ recvPacket12HS, onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret, getSessionData,+ clientLeafCertificate,+ restoreClientCertificate, storePrivInfo, isSupportedGroup, checkSupportedGroup,@@ -40,10 +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@@ -69,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@@ -77,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@@ -93,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)@@ -103,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) @@ -143,21 +153,45 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone +-- | '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 hss bss) -> return $ zip hss bss- Right x@(AppData _) -> do- -- If a TLS13 server decides to reject RTT0 data, the server should- -- skip records for RTT0 data up to the maximum limit.- established <- ctxEstablished ctx- case established of- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvPacketHandshake ctx- _ -> unexpected (show x) (Just "handshake")+ 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 @@ -182,7 +216,7 @@ 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@@ -224,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@@ -232,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@@ -250,6 +303,8 @@ , sessionALPN = alpn , sessionMaxEarlyDataSize = 0 , sessionFlags = flags+ , sessionClientCertificate = clientCert+ , sessionAppData = Nothing } -- | Store the specified keypair. Whether the public key and private key@@ -436,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.
Network/TLS/Handshake/Common13.hs view
@@ -60,7 +60,7 @@ import Network.TLS.Compression import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname)-import Network.TLS.Handshake.Common (unexpected)+import Network.TLS.Handshake.Common (clientLeafCertificate, unexpected) import Network.TLS.Handshake.Key import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State@@ -156,7 +156,7 @@ :: MonadIO m => Context -> PubKey- -> HashAndSignatureAlgorithm+ -> SignatureScheme -> TranscriptHash -> m Handshake13 makeCertVerify ctx pub hs (TranscriptHash hashValue) = do@@ -165,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@@ -199,7 +209,7 @@ :: MonadIO m => Context -> PubKey- -> HashAndSignatureAlgorithm+ -> SignatureScheme -> ByteString -> m Signature sign ctx pub hs target = liftIO $ do@@ -209,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@@ -349,6 +367,7 @@ malpn <- usingState_ ctx getNegotiatedProtocol sni <- usingState_ ctx getClientSNI mgrp <- usingHState ctx getSupportedGroup+ clientCert <- clientLeafCertificate ctx return SessionData { sessionVersion = ver@@ -361,6 +380,8 @@ , sessionALPN = malpn , sessionMaxEarlyDataSize = maxSize , sessionFlags = []+ , sessionClientCertificate = clientCert+ , sessionAppData = Nothing } ----------------------------------------------------------------@@ -434,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@@ -532,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@@ -684,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
Network/TLS/Handshake/Control.hs view
@@ -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 @\<secret\>@ 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 ++ ")" ----------------------------------------------------------------
Network/TLS/Handshake/Key.hs view
@@ -91,6 +91,9 @@ isDigitalSignatureKey (PubKeyEC _) = True isDigitalSignatureKey (PubKeyEd25519 _) = True isDigitalSignatureKey (PubKeyEd448 _) = True+isDigitalSignatureKey (PubKeyMLDSA44 _) = True+isDigitalSignatureKey (PubKeyMLDSA65 _) = True+isDigitalSignatureKey (PubKeyMLDSA87 _) = True isDigitalSignatureKey _ = False versionCompatible :: PubKey -> Version -> Bool@@ -99,6 +102,9 @@ versionCompatible (PubKeyEC _) v = v >= TLS10 versionCompatible (PubKeyEd25519 _) v = v >= TLS12 versionCompatible (PubKeyEd448 _) v = v >= TLS12+versionCompatible (PubKeyMLDSA44 _) v = v >= TLS13+versionCompatible (PubKeyMLDSA65 _) v = v >= TLS13+versionCompatible (PubKeyMLDSA87 _) v = v >= TLS13 versionCompatible _ _ = False {- FOURMOLU_ENABLE -} @@ -128,6 +134,9 @@ (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k (PubKeyEd25519 _, PrivKeyEd25519 _) -> True (PubKeyEd448 _, PrivKeyEd448 _) -> True+ (PubKeyMLDSA44 _, PrivKeyMLDSA44 _) -> True+ (PubKeyMLDSA65 _, PrivKeyMLDSA65 _) -> True+ (PubKeyMLDSA87 _, PrivKeyMLDSA87 _) -> True _ -> False getLocalPublicKey :: MonadIO m => Context -> m PubKey@@ -164,6 +173,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
Network/TLS/Handshake/Server.hs view
@@ -4,7 +4,10 @@ handshakeServer, handshakeServerWith, requestCertificateServer,+ requestCertificateAsyncServer, keyUpdate,+ sendKeyUpdate,+ respondToKeyUpdate, updateKey, KeyUpdateRequest (..), ) where@@ -35,7 +38,9 @@ handshakeServer sparams ctx = liftIO $ do hbs <- recvPacketHandshake ctx case hbs of- chb : _ -> handshake sparams ctx chb+ -- 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@@ -45,17 +50,15 @@ -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter.--- This is useful when the client hello has been already poped from the recv layer to inspect the packet.+-- This is useful when the client hello has been already popped from the recv layer to inspect the packet. ----- When the function returns, a new handshake has been succesfully negociated.+-- When the function returns, a new handshake has been successfully negotiated. -- On any error, a HandshakeFailed exception is raised. handshake :: ServerParams -> Context -> HandshakeR -> IO () handshake sparams ctx chb@(ClientHello ch, bs) = do (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. -- r0 :: Cipher, Hash, Bool (keyShareResult, r0, r1) <- processClientHello13 sparams ctx chI@@ -66,7 +69,7 @@ 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 SelectKeyShareFound cliKeyShare -> do unless (checkClientKeyShareKeyLength cliKeyShare) $@@ -86,4 +89,4 @@ 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")
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -57,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 @@ -81,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 $@@ -147,7 +157,9 @@ setupI :: Context -> ClientHello -> [ByteString] -> IO () setupI ctx chI@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR- unless hrr $ startHandshake ctx TLS13 chRandom+ 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@@ -155,11 +167,37 @@ setupO :: Context -> ClientHello -> [ByteString] -> IO () setupO ctx ch@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR- unless hrr $ startHandshake ctx chVersion chRandom+ 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 =@@ -170,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 =@@ -291,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
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -11,10 +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.Imports import Network.TLS.Parameters+import Network.TLS.Session (SessionManager (..)) import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types (CipherId (..), Role (..))@@ -32,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@@ -40,18 +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 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@@ -101,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@@ -129,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@@ -170,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 =
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -12,7 +12,9 @@ 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@@ -34,13 +36,24 @@ -> IO ( SelectKeyShareResult , (Cipher, Hash, Bool) -- rtt0- , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ , (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@@ -48,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@@ -59,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.@@ -76,14 +92,26 @@ extract _ = require keyShares <- lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract- let clientGroups =- take limitSupportedGroups $- lookupAndDecode- EID_SupportedGroups- MsgTClientHello- chExtensions- []- (\(SupportedGroups gs) -> gs)+ 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)@@ -126,14 +154,15 @@ -> Context -> (Cipher, Hash, Bool) -- rtt0 -> ClientHello- -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ -> 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 @@ -142,51 +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 (_, b) <- fromJust <$> usingHState ctx getClientHello- let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx+ 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@@ -195,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 =
Network/TLS/Handshake/Server/Common.hs view
@@ -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
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -50,6 +50,7 @@ usingState_ ctx $ do setSession chSession setTLS12SessionResuming True+ restoreClientCertificate ctx sessionData sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession sendPacket12 ctx $ Handshake [ServerHello sh] []@@ -93,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@@ -142,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@@ -153,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) <-@@ -186,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@@ -267,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
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -37,7 +37,8 @@ -> Context -> KeyShareEntry -> (Cipher, Hash, Bool) -- rtt0- -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN -> ClientHello -> Maybe ClientRandom -> IO@@ -46,7 +47,7 @@ , 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@@ -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@@ -288,9 +299,9 @@ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13- :: [HashAndSignatureAlgorithm]+ :: [SignatureScheme] -> Credentials- -> Maybe (Credential, HashAndSignatureAlgorithm)+ -> Maybe (Credential, SignatureScheme) credentialsFindForSigning13 hss0 creds = loop hss0 where loop [] = Nothing@@ -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@@ -322,7 +333,10 @@ usingState_ ctx $ setTLS13HRR True failOnEitherError $ setServerHelloParameters13 ctx usedCipher True hrr <- makeHRR ctx usedCipher usedHash chSession g isEch- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest+ 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
Network/TLS/Handshake/Server/TLS12.hs view
@@ -10,6 +10,7 @@ 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@@ -37,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] []+ _ -> return () sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx@@ -92,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.
Network/TLS/Handshake/Server/TLS13.hs view
@@ -1,15 +1,20 @@ {-# 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 Data.IORef @@ -28,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@@ -183,7 +189,16 @@ expectCertVerify :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()-expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do+expectCertVerify sparams ctx th h = liftIO $ do+ -- Commit the client certificate chain to the context.+ certs <- verifyCertVerify sparams ctx th h+ usingState_ ctx $ setClientCertificateChain certs++-- | Like 'expectCertVerify' but returns the chain instead of committing+-- it, which post-handshake authentication does only after Finished.+verifyCertVerify+ :: ServerParams -> Context -> TranscriptHash -> Handshake13 -> IO CertificateChain+verifyCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "invalid client certificate chain" pubkey <- case cc of@@ -193,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" ---------------------------------------------------------------- @@ -230,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@@ -239,23 +242,92 @@ origCertReqCtx <- newCertReqContext ctx let certReq13 = makeCertRequest sparams ctx origCertReqCtx False _ <- withWriteLock ctx $ do- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do sendPacket13 ctx $ Handshake13 [certReq13] [] withReadLock ctx $ do+ baseHState <- saveHState ctx+ -- 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- baseHState <- saveHState ctx updateTranscriptHash13 ctx (clientCert13, bClientCert13) th <- transcriptHash ctx "CH..Cert"- unless emptyCert $ do- (certVerify13, bCertVerify13) <- getHandshake ctx ref- expectCertVerify sparams ctx th certVerify13- updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+ mcerts <-+ if emptyCert+ then return Nothing+ else do+ (certVerify13, bCertVerify13) <- getHandshake ctx ref+ certs <- verifyCertVerify sparams ctx th certVerify13+ updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+ return $ Just certs (finished13, _bFinished13) <- getHandshake ctx ref- expectClientFinished ctx finished13+ thCf <- transcriptHash ctx "CH..<CF"+ expectClientFinished ctx thCf finished13+ forM_ mcerts $ usingState_ ctx . setClientCertificateChain void $ restoreHState ctx baseHState -- fixme return True +-- | The response is processed by 'recvData' as pending actions, so the+-- application keeps receiving data meanwhile.+requestCertificateAsyncServer+ :: ServerParams -> 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@@ -274,13 +346,26 @@ Error_Protocol "post handshake authenticated" UnexpectedMessage chk [] = getHandshake ctx ref 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+ when (mode == UpdateRequested) $+ withWriteLock ctx $+ respondToKeyUpdate ctx chk hbs chk (hb : hbs) = do writeIORef ref hbs@@ -309,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..<CF" checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData-expectClientFinished _ h = unexpected "Finished" $ Just $ show h+expectClientFinished _ _ h = unexpected "Finished" $ Just $ show h terminate :: Context -> TLSError -> IO a terminate ctx err = do@@ -328,18 +412,18 @@ 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 ----------------------------------------------------------------@@ -361,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@@ -369,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
Network/TLS/Handshake/Signature.hs view
@@ -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
Network/TLS/Handshake/State.hs view
@@ -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,@@ -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,13 +149,19 @@ , 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@@ -212,7 +219,7 @@ -- present Ed25519 and Ed448 certificates when these become supported. type CertReqCBdata = ( [CertificateType]- , Maybe [HashAndSignatureAlgorithm]+ , Maybe [SignatureScheme] , [DistinguishedName] ) @@ -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@@ -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})@@ -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 --
Network/TLS/Handshake/State13.hs view
@@ -13,10 +13,12 @@ setRxRecordState, getTxLevel, getRxLevel,+ getTxSequence, clearTxRecordState, clearRxRecordState, PendingRecvAction (..), setPendingRecvActions,+ pushPendingRecvAction, popPendingRecvAction, ) where @@ -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 @@ -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
− Network/TLS/HashAndSignature.hs
@@ -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 -}
Network/TLS/IO.hs view
@@ -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@@ -127,6 +134,9 @@ 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@@ -146,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@@ -181,6 +180,9 @@ 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@@ -194,6 +196,24 @@ ---------------------------------------------------------------- +-- 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@@ -203,9 +223,9 @@ 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 ---------------------------------------------------------------- @@ -223,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 ()
Network/TLS/IO/Decode.hs view
@@ -3,6 +3,7 @@ module Network.TLS.IO.Decode ( decodePacket12, decodePacket13,+ checkChangeCipherSpec, ) where import Control.Concurrent.MVar@@ -20,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 @@ -27,61 +29,90 @@ 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, wirebytes) <- gets stHandshakeRecordCont12 modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])}) (hss, bss) <-- unzip <$> parseMany currentParams mCont wirebytes (fragmentGetBytes fragment)+ unzip <$> parseMany decode mCont wirebytes (fragmentGetBytes fragment) return $ Handshake hss bss where- parseMany currentParams mCont wirebytes bs =+ parseMany decode mCont wirebytes bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont -> do modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)}) return [] GotSuccess (ty, content) ->- case decodeHandshake currentParams ty content of+ 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 h -> do- hbs <- parseMany currentParams Nothing [] left+ 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 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")+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, wirebytes) <- gets stHandshakeRecordCont13 modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])})@@ -106,4 +137,20 @@ let len = BS.length bs - BS.length left bs' = BS.take len bs return ((h, reverse (bs' : wirebytes)) : hbs)-decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")+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 ()
Network/TLS/Internal.hs view
@@ -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
Network/TLS/Packet.hs view
@@ -40,8 +40,8 @@ generateKeyBlock, -- * for extensions parsing- getSignatureHashAlgorithm,- putSignatureHashAlgorithm,+ getSignatureScheme,+ putSignatureScheme, getBinaryVersion, putBinaryVersion, getClientRandom32,@@ -76,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 ----------------------------------------------------------------@@ -157,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@@ -191,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@@ -253,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) ---- @@ -309,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)) ---- @@ -337,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)@@ -388,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@@ -488,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 ------------------------------------------------------------ @@ -534,12 +571,12 @@ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver = DigitallySigned- <$> getSignatureHashAlgorithm+ <$> getSignatureScheme <*> getOpaque16 putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned h sig) =- putSignatureHashAlgorithm h >> putOpaque16 sig+ putSignatureScheme h >> putOpaque16 sig ------------------------------------------------------------
Network/TLS/Packet13.hs view
@@ -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
Network/TLS/Parameters.hs view
@@ -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@@ -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@@ -401,8 +443,9 @@ -- -- Default: @[X25519,P256,P384,X448,P521,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192,X25519MLKEM768,P256MLKEM768,P384MLKEM1024,MLKEM768,MLKEM1024]@ , supportedGroupsTLS13 :: [[Group]]- -- ^ @[Group]@ contains @Group@s of the same level in preferred order.- -- @[Group]@ is also listed in preferred order.+ -- ^ 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. -- -- TLS 1.3 server: this is used as the 1st argument to -- 'onSelectKeyShare'.@@ -438,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@@ -554,7 +603,7 @@ -- document readable. type OnCertificateRequest = ( [CertificateType]- , Maybe [HashAndSignatureAlgorithm]+ , Maybe [SignatureScheme] , [DistinguishedName] ) -> IO (Maybe (CertificateChain, PrivKey))@@ -599,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@@ -612,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@@ -628,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])@@ -657,7 +714,7 @@ -- (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]@@ -722,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")@@ -738,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. --@@ -796,6 +853,16 @@ -- 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'@@ -815,6 +882,7 @@ , onALPNClientSuggest = Nothing , onEncryptedExtensionsCreating = return , onSelectKeyShare = defaultOnSelectKeyShare+ , onAccept0RTT = \_ -> return True } instance Show ServerHooks where@@ -850,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) @@ -870,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) @@ -883,5 +974,7 @@ defaultLimit = Limit { limitRecordSize = Nothing- , limitHandshakeFragment = 32+ , limitHandshakeFragment = 2048+ , limitKeyUpdate = Just 32+ , limitRecordsPerKey = Nothing }
Network/TLS/PostHandshake.hs view
@@ -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
Network/TLS/QUIC.hs view
@@ -116,7 +116,7 @@ { quicSend :: [(CryptLevel, ByteString)] -> IO () -- ^ Called by TLS so that QUIC sends one or more handshake fragments. The -- content transiting on this API is the plaintext of the fragments and- -- QUIC responsability is to encrypt this payload with the key material+ -- QUIC responsibility is to encrypt this payload with the key material -- given for the specified level and an appropriate encryption scheme. -- -- The size of the fragments may exceed QUIC datagram limits so QUIC may@@ -194,7 +194,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $- Error_Protocol "QUIC transport parameters are mssing" MissingExtension+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -222,7 +222,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $- Error_Protocol "QUIC transport parameters are mssing" MissingExtension+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)
Network/TLS/Record/Decrypt.hs view
@@ -2,6 +2,7 @@ module Network.TLS.Record.Decrypt ( decryptRecord,+ paddingIsValid, ) where import Control.Monad.State.Strict@@ -42,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 @@ -53,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 @@ -115,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@@ -134,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@@ -155,6 +191,7 @@ modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}} getCipherData record+ True CipherData { cipherDataContent = content , cipherDataMAC = Just mac@@ -194,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@@ -205,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
Network/TLS/Record/Recv.hs view
@@ -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+ ] ----------------------------------------------------------------
Network/TLS/Session.hs view
@@ -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 ()
+ Network/TLS/SignatureScheme.hs view
@@ -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 -}
Network/TLS/State.hs view
@@ -25,6 +25,7 @@ setVersion, setVersionIfUnset, getVersion,+ getVersionMaybe, getVersionWithDefault, setSecureRenegotiation, getSecureRenegotiation,@@ -231,6 +232,14 @@ getVersion = 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
Network/TLS/Struct.hs view
@@ -110,7 +110,7 @@ Handshake (..), packetType, typeOfHandshake,- module Network.TLS.HashAndSignature,+ module Network.TLS.SignatureScheme, ExtensionRaw (..), ExtensionID (..), showCertificateChain,@@ -134,7 +134,7 @@ import Network.TLS.Crypto import Network.TLS.Error import {-# SOURCE #-} Network.TLS.Extension-import Network.TLS.HashAndSignature+import Network.TLS.SignatureScheme import Network.TLS.Imports import Network.TLS.Types @@ -198,7 +198,7 @@ type Signature = ByteString -data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature+data DigitallySigned = DigitallySigned SignatureScheme Signature deriving (Eq) instance Show DigitallySigned where@@ -470,7 +470,7 @@ | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType]- [HashAndSignatureAlgorithm]+ [SignatureScheme] [DistinguishedName] | CertVerify DigitallySigned | Finished VerifyData
Network/TLS/Types.hs view
@@ -11,6 +11,7 @@ bigNumToInteger, bigNumFromInteger, defaultRecordSizeLimit,+ maxHandshakeSize, TranscriptHash (..), WireBytes, ) where@@ -58,6 +59,22 @@ -- 2^14 + 1 for TLS 1.3 defaultRecordSizeLimit :: Int defaultRecordSizeLimit = 16384++----------------------------------------------------------------++-- | 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 ----------------------------------------------------------------
Network/TLS/Types/Secret.hs view
@@ -1,5 +1,14 @@+-- | The secret types of the TLS key schedule.+--+-- None of these prints its key material: 'Show' renders @\<secret\>@, 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@@ -18,27 +27,39 @@ newtype BaseSecret a = BaseSecret Secret instance Show (BaseSecret a) where- show (BaseSecret bs) = showBytesHex $ convert bs+ show _ = "<secret>" +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 $ convert bs+ show _ = "<secret>" +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 Secret instance Show (ClientTrafficSecret a) where- show (ClientTrafficSecret bs) = showBytesHex $ convert bs+ show _ = "<secret>" +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 Secret instance Show (ServerTrafficSecret a) where- show (ServerTrafficSecret bs) = showBytesHex $ convert bs+ show _ = "<secret>" +instance DebugShow (ServerTrafficSecret a) where+ debugShow (ServerTrafficSecret bs) = showBytesHex $ convert bs+ data SecretTriple a = SecretTriple { triBase :: BaseSecret a , triClient :: ClientTrafficSecret a@@ -55,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 _ = "<secret>"++instance DebugShow ExporterSecret where+ debugShow (ExporterSecret bs) = showBytesHex $ convert bs+ -- Main secret for TLS 1.2 or earlier. newtype MainSecret = MainSecret Secret instance Show MainSecret where- show (MainSecret bs) = showBytesHex $ convert bs+ show _ = "<secret>"++instance DebugShow MainSecret where+ debugShow (MainSecret bs) = showBytesHex $ convert bs
Network/TLS/Types/Session.hs view
@@ -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)@@ -45,8 +46,78 @@ , 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 @\<secret\>@: whoever+-- has it can resume the session. 'Crypto.Debug.debugShow' renders it.+instance Show SessionData where+ showsPrec = showsSessionData (showString "<secret>")++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
Network/TLS/Util.hs view
@@ -18,7 +18,6 @@ ) 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@@ -83,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])
Network/TLS/Wire.hs view
@@ -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
test/Arbitrary.hs view
@@ -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@@ -220,6 +222,22 @@ , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)+ ]++-- | One credential per ML-DSA parameter set.+arbitraryCredentialsOfEachMLDSA :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachMLDSA = do+ (pub44, priv44) <- arbitraryMLDSA44Pair+ (pub65, priv65) <- arbitraryMLDSA65Pair+ (pub87, priv87) <- arbitraryMLDSA87Pair+ mapM+ ( \(pub, priv) -> do+ cert <- arbitraryX509WithKey (pub, priv)+ return (CertificateChain [cert], priv)+ )+ [ (PubKeyMLDSA44 pub44, PrivKeyMLDSA44 (privkeyMLDSAFromKey priv44))+ , (PubKeyMLDSA65 pub65, PrivKeyMLDSA65 (privkeyMLDSAFromKey priv65))+ , (PubKeyMLDSA87 pub87, PrivKeyMLDSA87 (privkeyMLDSAFromKey priv87)) ] arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)]
test/Certificate.hs view
@@ -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
+ test/ChannelBindingSpec.hs view
@@ -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 \<client random\> \<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"
test/CiphersSpec.hs view
@@ -5,6 +5,7 @@ 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@@ -20,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
test/ECHSpec.hs view
@@ -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 -------------------------------------------------------------- @@ -439,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
test/EncodeSpec.hs view
@@ -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))))+
test/HandshakeSpec.hs view
@@ -2,1041 +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- , 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 =- [ (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- , supportedGroupsTLS13 = [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]- , supportedGroupsTLS13 = [[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]- , 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--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--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_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--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 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- , 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--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
test/PubKey.hs view
@@ -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
test/Run.hs view
@@ -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: ")
+ test/SecretSpec.hs view
@@ -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+ "<secret>" `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+ "<secret>" `isInfixOf` shown `shouldBe` True+ hexOf "a5" `isInfixOf` debugShow x `shouldBe` True
tls.cabal view
@@ -1,6 +1,6 @@-cabal-version: >=1.10+cabal-version: 2.0 name: tls-version: 2.3.1+version: 2.5.1 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -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@@ -121,23 +124,22 @@ base16-bytestring, bytestring >=0.10 && <0.13, cereal >=0.5.3 && <0.6,- crypton >=1.1.2 && <1.2,+ 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.9 && <1.10,- crypton-x509-store >=1.9 && <1.10,- crypton-x509-validation >=1.9 && <1.10,+ crypton-x509 >=1.10 && <1.11,+ crypton-x509-store >=1.10 && <1.11,+ crypton-x509-validation >=1.10 && <1.11, data-default,- ech-config,- hpke >=0.1.0 && <0.2,- mlkem >= 0.2.0 && <0.3,+ 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.5,+ unix-time >=0.4.11 && <0.7, zlib >=0.7 && <0.8 executable tls-server@@ -189,7 +191,7 @@ crypton-x509-system, ech-config, network,- network-run >=0.5,+ network-run >=0.6.0 && < 0.7, tls if flag(devel)@@ -206,6 +208,7 @@ API Arbitrary Certificate+ ChannelBindingSpec CiphersSpec ECHSpec EncodeSpec@@ -213,6 +216,7 @@ PipeChan PubKey Run+ SecretSpec Session ThreadSpec @@ -234,46 +238,5 @@ ram, serialise, time-hourglass,- tls--benchmark tls-bench- type: exitcode-stdio-1.0- main-is: Benchmarks.hs- hs-source-dirs: Benchmarks test- other-modules:- API- Arbitrary- Certificate- CiphersSpec- ECHSpec- EncodeSpec- HandshakeSpec- PipeChan- PubKey- Run- Session- ThreadSpec-- default-language: Haskell2010- ghc-options: -Wall- build-depends:- base >=4.9 && <5,- QuickCheck,- async,- base64-bytestring,- bytestring,- containers,- crypton,- crypton-asn1-types,- crypton-x509,- crypton-x509-store,- crypton-x509-validation,- data-default,- ech-config,- hspec,- network,- network-run,- serialise,- tasty-bench,- time-hourglass,- tls+ tls,+ zlib
util/Common.hs view
@@ -111,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
util/Server.hs view
@@ -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 = "<html><<body>Hello world!</body></html>" +-- 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
util/tls-server.hs view
@@ -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}) "<groups>")+ (ReqArg (\gs o -> o{optGroups = Just $ readGroups gs}) "<groups>") "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}) "<name>")+ "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 <addr> and <port>\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 }