tls 2.0.6 → 2.4.9
raw patch · 103 files changed
Files
- Benchmarks/Benchmarks.hs +187/−0
- CHANGELOG.md +257/−1
- Network/TLS.hs +159/−20
- Network/TLS/Backend.hs +16/−3
- Network/TLS/Cipher.hs +17/−75
- Network/TLS/Compression.hs +2/−1
- Network/TLS/Context.hs +45/−20
- Network/TLS/Context/Internal.hs +177/−54
- Network/TLS/Core.hs +200/−153
- Network/TLS/Credentials.hs +4/−3
- Network/TLS/Crypto.hs +52/−31
- Network/TLS/Crypto/DH.hs +7/−5
- Network/TLS/Crypto/IES.hs +385/−124
- Network/TLS/Crypto/Types.hs +60/−2
- Network/TLS/Error.hs +197/−0
- Network/TLS/Extension.hs +1209/−625
- Network/TLS/Extension.hs-boot +22/−0
- Network/TLS/Extra/Cipher.hs +551/−303
- Network/TLS/Extra/CipherCBC.hs +201/−0
- Network/TLS/Handshake.hs +4/−5
- Network/TLS/Handshake/Certificate.hs +24/−3
- Network/TLS/Handshake/Client.hs +66/−45
- Network/TLS/Handshake/Client/ClientHello.hs +436/−134
- Network/TLS/Handshake/Client/Common.hs +43/−13
- Network/TLS/Handshake/Client/ServerHello.hs +173/−64
- Network/TLS/Handshake/Client/TLS12.hs +38/−32
- Network/TLS/Handshake/Client/TLS13.hs +87/−51
- Network/TLS/Handshake/Common.hs +192/−59
- Network/TLS/Handshake/Common13.hs +264/−158
- Network/TLS/Handshake/Control.hs +24/−0
- Network/TLS/Handshake/Key.hs +17/−14
- Network/TLS/Handshake/Process.hs +0/−35
- Network/TLS/Handshake/Random.hs +20/−47
- Network/TLS/Handshake/Server.hs +41/−43
- Network/TLS/Handshake/Server/ClientHello.hs +236/−35
- Network/TLS/Handshake/Server/ClientHello12.hs +114/−52
- Network/TLS/Handshake/Server/ClientHello13.hs +176/−73
- Network/TLS/Handshake/Server/Common.hs +124/−42
- Network/TLS/Handshake/Server/ServerHello12.hs +127/−112
- Network/TLS/Handshake/Server/ServerHello13.hs +207/−143
- Network/TLS/Handshake/Server/TLS12.hs +49/−26
- Network/TLS/Handshake/Server/TLS13.hs +214/−51
- Network/TLS/Handshake/Signature.hs +34/−3
- Network/TLS/Handshake/State.hs +134/−129
- Network/TLS/Handshake/State13.hs +5/−58
- Network/TLS/Handshake/TranscriptHash.hs +131/−0
- Network/TLS/HashAndSignature.hs +181/−0
- Network/TLS/Hooks.hs +6/−4
- Network/TLS/IO.hs +132/−72
- Network/TLS/IO/Decode.hs +150/−0
- Network/TLS/IO/Encode.hs +148/−0
- Network/TLS/Imports.hs +4/−8
- Network/TLS/Internal.hs +19/−6
- Network/TLS/KeySchedule.hs +13/−8
- Network/TLS/MAC.hs +35/−31
- Network/TLS/Packet.hs +275/−203
- Network/TLS/Packet13.hs +145/−62
- Network/TLS/Parameters.hs +467/−194
- Network/TLS/PostHandshake.hs +16/−15
- Network/TLS/QUIC.hs +18/−11
- Network/TLS/Receiving.hs +0/−90
- Network/TLS/Record.hs +5/−6
- Network/TLS/Record/Decrypt.hs +243/−0
- Network/TLS/Record/Disengage.hs +0/−193
- Network/TLS/Record/Encrypt.hs +131/−0
- Network/TLS/Record/Engage.hs +0/−139
- Network/TLS/Record/Layer.hs +2/−2
- Network/TLS/Record/Reading.hs +0/−103
- Network/TLS/Record/Recv.hs +133/−0
- Network/TLS/Record/Send.hs +61/−0
- Network/TLS/Record/State.hs +5/−4
- Network/TLS/Record/Types.hs +7/−29
- Network/TLS/Record/Writing.hs +0/−59
- Network/TLS/Sending.hs +0/−124
- Network/TLS/Session.hs +8/−6
- Network/TLS/State.hs +100/−73
- Network/TLS/Struct.hs +172/−591
- Network/TLS/Struct13.hs +39/−16
- Network/TLS/Types.hs +57/−155
- Network/TLS/Types/Cipher.hs +130/−0
- Network/TLS/Types/Secret.hs +86/−0
- Network/TLS/Types/Session.hs +109/−0
- Network/TLS/Types/Version.hs +40/−0
- Network/TLS/Util.hs +32/−19
- Network/TLS/Util/ASN1.hs +1/−0
- Network/TLS/Wire.hs +7/−2
- Network/TLS/X509.hs +22/−0
- test/Arbitrary.hs +63/−44
- test/Certificate.hs +21/−0
- test/CiphersSpec.hs +5/−3
- test/ECHSpec.hs +446/−0
- test/EncodeSpec.hs +251/−0
- test/HandshakeSpec.hs +2292/−1012
- test/PubKey.hs +1/−0
- test/Run.hs +169/−8
- test/SecretSpec.hs +63/−0
- test/Session.hs +2/−2
- tls.cabal +133/−74
- util/Client.hs +35/−18
- util/Common.hs +29/−62
- util/Server.hs +58/−18
- util/tls-client.hs +201/−62
- util/tls-server.hs +292/−32
+ Benchmarks/Benchmarks.hs view
@@ -0,0 +1,187 @@+{-# 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,3 +1,259 @@+# Change log for "tls"++## Version 2.4.9++* Include CertificateRequest in the post-handshake auth transcript.+ This breaks PHA with hs-tls 2.4.8 or earlier.+ [#565](https://github.com/haskell-tls/hs-tls/pull/565)+* Send a TLS 1.2 session ticket only to a client that asked for one.+ [#575](https://github.com/haskell-tls/hs-tls/pull/575)+* Fall back to a full handshake when a PSK finds a TLS 1.2 session.+ [#576](https://github.com/haskell-tls/hs-tls/pull/576)+* Refuse SCSV or a missing renegotiation_info in secure renegotiation.+ [#566](https://github.com/haskell-tls/hs-tls/pull/566)+* Reject a hybrid key share whose classical part fails to derive.+ [#550](https://github.com/haskell-tls/hs-tls/pull/550)+* Send no SNI for an empty server name, and refuse a malformed or+ invalid server_name.+ [#568](https://github.com/haskell-tls/hs-tls/pull/568)+* Refuse a CertificateVerify algorithm that is not offered or does not+ fit the key with illegal_parameter.+ [#562](https://github.com/haskell-tls/hs-tls/pull/562)+ [#578](https://github.com/haskell-tls/hs-tls/pull/578)+* Accept an empty TLS 1.2 client certificate when the hook does.+ [#552](https://github.com/haskell-tls/hs-tls/pull/552)+* Request EdDSA client certificates with ecdsa_sign in TLS 1.2.+ [#553](https://github.com/haskell-tls/hs-tls/pull/553)+* Accept a ClientHello whose legacy_version is above TLS 1.2.+ [#564](https://github.com/haskell-tls/hs-tls/pull/564)+* Answer malformed or misplaced messages with the alerts the RFCs ask for.+ [#554](https://github.com/haskell-tls/hs-tls/pull/554)+ [#555](https://github.com/haskell-tls/hs-tls/pull/555)+ [#556](https://github.com/haskell-tls/hs-tls/pull/556)+ [#557](https://github.com/haskell-tls/hs-tls/pull/557)+ [#558](https://github.com/haskell-tls/hs-tls/pull/558)+ [#559](https://github.com/haskell-tls/hs-tls/pull/559)+ [#560](https://github.com/haskell-tls/hs-tls/pull/560)+ [#561](https://github.com/haskell-tls/hs-tls/pull/561)+ [#563](https://github.com/haskell-tls/hs-tls/pull/563)+ [#567](https://github.com/haskell-tls/hs-tls/pull/567)+ [#569](https://github.com/haskell-tls/hs-tls/pull/569)+ [#570](https://github.com/haskell-tls/hs-tls/pull/570)+ [#571](https://github.com/haskell-tls/hs-tls/pull/571)+* tls-server: new options for tlsfuzzer, which CI runs weekly.+ [#551](https://github.com/haskell-tls/hs-tls/pull/551)+ [#572](https://github.com/haskell-tls/hs-tls/pull/572)+ [#573](https://github.com/haskell-tls/hs-tls/pull/573)+ [#574](https://github.com/haskell-tls/hs-tls/pull/574)+ [#577](https://github.com/haskell-tls/hs-tls/pull/577)++## Version 2.4.8++* Stop printing traffic secrets and the session secret.+ [#549](https://github.com/haskell-tls/hs-tls/pull/549)++## Version 2.4.7++* Use the one-call AES-GCM and ChaCha20-Poly1305 interfaces of crypton.+ This needs crypton 2.1.1 or later.+ [#548](https://github.com/haskell-tls/hs-tls/pull/548)++## Version 2.4.6++* Accept crypton 2.1.++## Version 2.4.5++* Fix the TLS 1.3 0-RTT session tests racing the NewSessionTicket.+ [#547](https://github.com/haskell-tls/hs-tls/pull/547)+* CI: drop macOS with GHC 9.12.+ [#546](https://github.com/haskell-tls/hs-tls/pull/546)+* CI: retry Hackage downloads, keep the cache when a test fails, and run+ doctest on one job.+ [#545](https://github.com/haskell-tls/hs-tls/pull/545)+* `extensionDecode` returns `Nothing` instead of calling `error`.+ [#544](https://github.com/haskell-tls/hs-tls/pull/544)+* `getTLSUnique` and `getTLSExporter` return `Nothing` before a handshake.+ [#543](https://github.com/haskell-tls/hs-tls/pull/543)+* Take two timing signals out of the CBC record path.+ [#542](https://github.com/haskell-tls/hs-tls/pull/542)+* Bound the size of a handshake message reassembled from records.+ [#541](https://github.com/haskell-tls/hs-tls/pull/541)+* CI: speed up.+ [#540](https://github.com/haskell-tls/hs-tls/pull/540)+* Limit consecutive TLS 1.3 KeyUpdate messages with the new+ `limitKeyUpdate` parameter.+ [#539](https://github.com/haskell-tls/hs-tls/pull/539)+* Validate the negotiated ALPN protocol.+ [#538](https://github.com/haskell-tls/hs-tls/pull/538)+* Validate the negotiated cipher suite.+ [#537](https://github.com/haskell-tls/hs-tls/pull/537)+* Make the session ticket tests deterministic.+ [#536](https://github.com/haskell-tls/hs-tls/pull/536)++## Version 2.4.4++* Enforce server certificate purpose+ [#534](https://github.com/haskell-tls/hs-tls/pull/534)+* Use dedicated doctest REPL+ [#533](https://github.com/haskell-tls/hs-tls/pull/533)+* Bind early data to ALPN+ [#532](https://github.com/haskell-tls/hs-tls/pull/532)+* Bound certificate decompression+ [#531](https://github.com/haskell-tls/hs-tls/pull/531)+* Fix RecordOverflow race after TLS 1.3 client authentication+ [#530](https://github.com/haskell-tls/hs-tls/pull/530)++## Version 2.4.3++* A server checks clientAuth of ExtendedKeyUsage in a client+ certificate on client authentication.++## Version 2.4.2++* The `Network.TLS.Extra.CipherCBC` module is added.+ [#526](https://github.com/haskell-tls/hs-tls/pull/526)++## Version 2.4.1++* Ensure same `supported_groups` before/after HRR.+* New `clientWantTicket` parameter makes it possible to opt-out of soliciting+ session tickets from servers.++## Version 2.4.0++* Identical to v2.3.1 but major version up as v2.3.1 breaks "quic".++## Version 2.3.1 (deprecated)++* Using ScrubbedBytes for secrets.+* Key echange with ML-KEM.+ [#517](https://github.com/haskell-tls/hs-tls/pull/517)+* Expose get certificate chain function+ [#520](https://github.com/haskell-tls/hs-tls/pull/520)++## Version 2.3.0++* Using "ram" instead of "memory".++## Version 2.2.2++* A new architecture to calculate receiver's transcript hash with wire+ format.+ [#515](https://github.com/haskell-tls/hs-tls/pull/515)+* Enabling compressed certificate on the client side again.++## Version 2.2.1++* Disabling compressed certificate on the client side.+ [#514](https://github.com/haskell-tls/hs-tls/issues/514)++## Version 2.2.0++* Using crypton-asn1-* and time-hourglass.+ [#512](https://github.com/haskell-tls/hs-tls/pull/512)+* Major version up due to re-exports.++## Version 2.1.14++* Supporting P384 and P521 curves.+ [#511](https://github.com/haskell-tls/hs-tls/pull/511)+* Fixing some bugs of `tls-client`.++## Version 2.1.13++* Don't contain early_data if serverEarlyDataSize is 0.+ [#510](https://github.com/haskell-tls/hs-tls/pull/510)++## Version 2.1.12++* Restore benchmarks.+ [#509](https://github.com/haskell-tls/hs-tls/pull/509)+* Supporting random 1.2.+ [#508](https://github.com/haskell-tls/hs-tls/pull/508)+* Add --trusted-anchor cli option to tls-client.+ [#505](https://github.com/haskell-tls/hs-tls/pull/505)++## Version 2.1.11++* Removing OVERLAPS instances.++## Version 2.1.10++* Supporting the SSLKEYLOGFILE environment variable.+ [#499](https://github.com/haskell-tls/hs-tls/pull/499)++## Version 2.1.9++* Providing ECH(Encrypted Client Hello). See `sharedECHConfigList`,+ `clientUseECH` and `serverECHKey`. Note that the `ech-gen` command,+ `loadECHConfigList` and `loadECHSecretKeys` are provided by the+ `ech-config` package.++## Version 2.1.8++* Moving `Limit` to `Shared` to maintain backward compatibility+ of `TLSParams` class.+* Deprecating 2.1.7.++## Version 2.1.7++* Introducing `Limit` parameter.+* Implementing "Record Size Limit Extension for TLS" (RFC8449).+ Set `limitRecordSize` use it.+* Implementing "TLS Certificate Compression" (RFC 8879).+ This feature is automatically used if the peer supports it.+* More tests with `tlsfuzzer` especially for client authentication+ and 0-RTT.+* 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 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.+* `tls-client -d` and `tls-server -d` pretty-prints `Handshake`.++## Version 2.1.5++* Removing the dependency on the async package.+* Restore a few DHE_RSA ciphers.+ [#493](https://github.com/haskell-tls/hs-tls/pull/493)++## Version 2.1.4++* Exporting defaultValidationCache.++## Version 2.1.3++* Remove `data-default` version constraint.+ [#492](https://github.com/haskell-tls/hs-tls/pull/492)+* Exporting default variables.+ [#448](https://github.com/haskell-tls/hs-tls/pull/488)++## Version 2.1.2++* Using data-default instead of data-default-class.++## Version 2.1.1++* `bye` directly calls `timeout recvHS13`, not spawning a thread for+ `timeout recvHS13`. So, `bye` can receive an exception if thrown.++## Version 2.1.0++* Breaking change: stop exporting constructors to maintain future+ compatibilities. Field names are still exported, and values can be updated+ with them using record syntax. Use `def` and `noSessionManager` as initial+ values.+* `onServerFinished` is added to `ClientHooks`.+* `clientWantSessionResumeList` is added to `ClientParams` to support+ multiple tickets for TLS 1.3.+ ## Version 2.0.6 * Setting `supportedCiphers` in `defaultSupported` to `ciphersuite_default`.@@ -220,7 +476,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
@@ -10,6 +10,14 @@ -- Currently implement the TLS1.2 and TLS 1.3 -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions.+--+-- The typical usage is:+--+-- > socket <- ...+-- > ctx <- contextNew socket <params>+-- > handshake ctx+-- > ... (using recvData and sendData)+-- > bye module Network.TLS ( -- * Basic APIs Context,@@ -30,26 +38,110 @@ -- intentionally hide the internal methods even haddock warns. TLSParams,- ClientParams (..),++ -- ** Client parameters+ ClientParams, defaultParamsClient,- ServerParams (..),+ clientServerIdentification,+ clientUseServerNameIndication,+ clientWantSessionResume,+ clientWantSessionResumeList,+ clientWantTicket,+ clientShared,+ clientHooks,+ clientSupported,+ clientDebug,+ clientUseEarlyData,+ clientUseECH, + -- ** Server parameters+ ServerParams,+ defaultParamsServer,+ serverWantClientCert,+ serverCACertificates,+ serverDHEParams,+ serverHooks,+ serverShared,+ serverSupported,+ serverDebug,+ serverEarlyDataSize,+ serverTicketLifetime,+ serverECHKey,+ -- ** Shared- Shared (..),+ Shared,+ defaultShared,+ sharedCredentials,+ sharedSessionManager,+ sharedCAStore,+ sharedValidationCache,+ sharedHelloExtensions,+ sharedECHConfigList,+ sharedLimit, - -- ** Hooks- ClientHooks (..),+ -- ** Client hooks+ ClientHooks,+ defaultClientHooks, OnCertificateRequest,+ onCertificateRequest, OnServerCertificate,- ServerHooks (..),- Measurement (..),+ onServerCertificate,+ onSuggestALPN,+ onCustomFFDHEGroup,+ onServerFinished,+ onSelectKeyShareGroups, + -- ** Server hooks+ ServerHooks,+ defaultServerHooks,+ onClientCertificate,+ validateClientCertificate,+ onUnverifiedClientCert,+ onCipherChoosing,+ onServerNameIndication,+ onNewHandshake,+ onALPNClientSuggest,+ onEncryptedExtensionsCreating,+ onSelectKeyShare,+ Measurement,+ nbHandshakes,+ bytesReceived,+ bytesSent,+ -- ** Supported- Supported (..),+ Supported,+ defaultSupported,+ supportedVersions,+ supportedCiphers,+ supportedCompressions,+ supportedHashSignatures,+ supportedSecureRenegotiation,+ supportedClientInitiatedRenegotiation,+ supportedExtendedMainSecret,+ supportedSession,+ supportedFallbackScsv,+ supportedEmptyPacket,+ supportedGroups,+ supportedGroupsTLS13, -- ** Debug parameters- DebugParams (..),+ DebugParams,+ defaultDebugParams,+ debugSeed,+ debugPrintSeed,+ debugVersionForced,+ debugKeyLogger,+ defaultKeyLogger,+ debugError,+ debugTraceKey, + -- ** Limit parameters+ Limit,+ defaultLimit,+ limitHandshakeFragment,+ limitKeyUpdate,+ limitRecordSize,+ -- * Shared parameters -- ** Credentials@@ -61,17 +153,36 @@ credentialLoadX509ChainFromMemory, -- ** Session manager- SessionManager (..),+ SessionManager, noSessionManager,+ sessionResume,+ sessionResumeOnlyOnce,+ sessionEstablish,+ sessionInvalidate,+ sessionUseTicket, SessionID, SessionIDorTicket, Ticket,- SessionData (..),++ -- ** Session data+ SessionData,+ sessionVersion,+ sessionCipher,+ sessionCompression,+ sessionClientSNI,+ sessionSecret,+ sessionGroup,+ sessionTicketInfo,+ sessionALPN,+ sessionMaxEarlyDataSize,+ sessionFlags, SessionFlag (..), TLS13TicketInfo,+ is0RTTPossible, -- ** Validation Cache ValidationCache (..),+ defaultValidationCache, ValidationCacheQueryCallback, ValidationCacheAddCallback, ValidationCacheResult (..),@@ -98,6 +209,7 @@ CertificateUsage (..), CertificateRejectReason (..), CertificateType (..),+ CertificateChain (..), HostName, MaxFragmentEnum (..), @@ -109,14 +221,27 @@ contextClose, -- ** Information gathering- Information (..),+ Information, contextGetInformation,+ infoVersion,+ infoCipher,+ infoCompression,+ infoMainSecret,+ infoExtendedMainSecret,+ infoClientRandom,+ infoServerRandom,+ infoSupportedGroup,+ infoTLS12Resumption,+ infoTLS13HandshakeMode,+ infoIsEarlyDataAccepted,+ infoIsECHAccepted, ClientRandom, ServerRandom, unClientRandom, unServerRandom, HandshakeMode13 (..), getClientCertificateChain,+ getServerCertificateChain, -- ** Negotiated getNegotiatedProtocol,@@ -133,14 +258,24 @@ getPeerFinished, -- ** Modifying hooks in context- Hooks (..),+ Hooks,+ defaultHooks,+ hookRecvHandshake,+ hookRecvHandshake13,+ hookRecvCertificates,+ hookLogging, contextModifyHooks, Handshake, contextHookSetHandshakeRecv, Handshake13, contextHookSetHandshake13Recv, contextHookSetCertificateRecv,- Logging (..),+ Logging,+ defaultLogging,+ loggingPacketSent,+ loggingPacketRecv,+ loggingIOSent,+ loggingIORecv, Header (..), ProtocolType (..), contextHookSetLogging,@@ -173,8 +308,12 @@ Bytes, ValidationChecks (..), ValidationHooks (..),+ clientUseMaxFragmentLength, ) where +import Data.X509 (PrivKey (..), PubKey (..))+import Data.X509.Validation hiding (HostName, defaultHooks)+ import Network.TLS.Backend (Backend (..), HasBackend (..)) import Network.TLS.Cipher import Network.TLS.Compression (@@ -188,12 +327,13 @@ import Network.TLS.Crypto ( DHParams, DHPublic,- Group (..), KxError (..), supportedNamedGroups, )+import Network.TLS.Extension import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks+import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Session@@ -217,12 +357,8 @@ import Network.TLS.Types import Network.TLS.X509 -import Data.ByteString as B-import Data.X509 (PrivKey (..), PubKey (..))-import Data.X509.Validation hiding (HostName)- {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-}-type Bytes = B.ByteString+type Bytes = ByteString -- | Getting certificates from a client, if any. -- Note that the certificates are not sent by a client@@ -231,6 +367,9 @@ -- both cases of full-negotiation and resumption. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain++getServerCertificateChain :: Context -> IO (Maybe CertificateChain)+getServerCertificateChain ctx = usingState_ ctx S.getServerCertificateChain -- $exceptions -- Since 1.8.0, this library only throws exceptions of type 'TLSException'.
Network/TLS/Backend.hs view
@@ -15,9 +15,10 @@ import qualified Data.ByteString as B import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network-import Network.TLS.Imports import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) +import Network.TLS.Imports+ -- | Connection IO backend data Backend = Backend { backendFlush :: IO ()@@ -43,7 +44,13 @@ instance HasBackend Network.Socket where initializeBackend _ = return ()- getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll+ getBackend sock =+ Backend+ { backendFlush = return ()+ , backendClose = Network.close sock+ , backendSend = Network.sendAll sock+ , backendRecv = recvAll+ } where recvAll n = B.concat <$> loop n where@@ -56,4 +63,10 @@ instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering- getBackend handle = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle)+ getBackend handle =+ Backend+ { backendFlush = hFlush handle+ , backendClose = hClose handle+ , backendSend = B.hPut handle+ , backendRecv = B.hGet handle+ }
Network/TLS/Cipher.hs view
@@ -22,19 +22,14 @@ cipherAllowedForVersion, hasMAC, hasRecordIV,+ elemCipher,+ intersectCiphers,+ findCipher, ) where -import Crypto.Cipher.Types (AuthTag) import Network.TLS.Crypto (Hash (..), hashDigestSize)-import Network.TLS.Types (CipherID, Version (..))--import qualified Data.ByteString as B---- FIXME convert to newtype-type BulkKey = B.ByteString-type BulkIV = B.ByteString-type BulkNonce = B.ByteString-type BulkAdditionalData = B.ByteString+import Network.TLS.Imports+import Network.TLS.Types data BulkState = BulkStateStream BulkStream@@ -48,16 +43,6 @@ show (BulkStateAEAD _) = "BulkStateAEAD" show BulkStateUninitialized = "BulkStateUninitialized" -newtype BulkStream = BulkStream (B.ByteString -> (B.ByteString, BulkStream))--type BulkBlock = BulkIV -> B.ByteString -> (B.ByteString, BulkIV)--type BulkAEAD =- BulkNonce -> B.ByteString -> BulkAdditionalData -> (B.ByteString, AuthTag)--data BulkDirection = BulkEncrypt | BulkDecrypt- deriving (Show, Eq)- bulkInit :: Bulk -> BulkDirection -> BulkKey -> BulkState bulkInit bulk direction key = case bulkF bulk of@@ -65,63 +50,12 @@ BulkStreamF ini -> BulkStateStream (ini direction key) BulkAeadF ini -> BulkStateAEAD (ini direction key) -data BulkFunctions- = BulkBlockF (BulkDirection -> BulkKey -> BulkBlock)- | BulkStreamF (BulkDirection -> BulkKey -> BulkStream)- | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD)- hasMAC, hasRecordIV :: BulkFunctions -> Bool hasMAC (BulkBlockF _) = True hasMAC (BulkStreamF _) = True hasMAC (BulkAeadF _) = False hasRecordIV = hasMAC -data CipherKeyExchangeType- = CipherKeyExchange_RSA- | CipherKeyExchange_DH_Anon- | CipherKeyExchange_DHE_RSA- | CipherKeyExchange_ECDHE_RSA- | CipherKeyExchange_DHE_DSA- | CipherKeyExchange_DH_DSA- | CipherKeyExchange_DH_RSA- | CipherKeyExchange_ECDH_ECDSA- | CipherKeyExchange_ECDH_RSA- | CipherKeyExchange_ECDHE_ECDSA- | CipherKeyExchange_TLS13 -- not expressed in cipher suite- deriving (Show, Eq)--data Bulk = Bulk- { bulkName :: String- , bulkKeySize :: Int- , bulkIVSize :: Int- , bulkExplicitIV :: Int -- Explicit size for IV for AEAD Cipher, 0 otherwise- , bulkAuthTagLen :: Int -- Authentication tag length in bytes for AEAD Cipher, 0 otherwise- , bulkBlockSize :: Int- , bulkF :: BulkFunctions- }--instance Show Bulk where- show bulk = bulkName bulk-instance Eq Bulk where- b1 == b2 =- and- [ bulkName b1 == bulkName b2- , bulkKeySize b1 == bulkKeySize b2- , bulkIVSize b1 == bulkIVSize b2- , bulkBlockSize b1 == bulkBlockSize b2- ]---- | Cipher algorithm-data Cipher = Cipher- { cipherID :: CipherID- , cipherName :: String- , cipherHash :: Hash- , cipherBulk :: Bulk- , cipherKeyExchange :: CipherKeyExchangeType- , cipherMinVer :: Maybe Version- , cipherPRFHash :: Maybe Hash- }- cipherKeyBlockSize :: Cipher -> Int cipherKeyBlockSize cipher = 2 * (hashDigestSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk) where@@ -135,8 +69,16 @@ Nothing -> ver < TLS13 Just cVer -> cVer <= ver && (ver < TLS13 || cVer >= TLS13) -instance Show Cipher where- show c = cipherName c+eqCipher :: CipherID -> Cipher -> Bool+eqCipher cid c = cipherID c == cid -instance Eq Cipher where- (==) c1 c2 = cipherID c1 == cipherID c2+elemCipher :: [CipherId] -> Cipher -> Bool+elemCipher cids c = cid `elem` cids+ where+ cid = CipherId $ cipherID c++intersectCiphers :: [CipherId] -> [Cipher] -> [Cipher]+intersectCiphers peerCiphers myCiphers = filter (elemCipher peerCiphers) myCiphers++findCipher :: CipherID -> [Cipher] -> Maybe Cipher+findCipher cid = find $ eqCipher cid
Network/TLS/Compression.hs view
@@ -18,6 +18,7 @@ ) where import Control.Arrow (first)+ import Network.TLS.Imports import Network.TLS.Types (CompressionID) @@ -50,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,6 +8,7 @@ Context (..), Hooks (..), Established (..),+ PendingRecv (..), RecordLayer (..), ctxEOF, ctxEstablished,@@ -23,6 +24,7 @@ updateMeasure, withMeasure, withReadLock,+ tryWithReadLock, withWriteLock, withStateLock, withRWLock,@@ -58,6 +60,15 @@ TLS13State (..), getTLS13State, modifyTLS13State,+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef, ) where import Control.Concurrent.MVar@@ -83,26 +94,29 @@ import Network.TLS.Parameters import Network.TLS.PostHandshake ( postHandshakeAuthClientWith,- postHandshakeAuthServerWith, requestCertificateServer, ) import Network.TLS.RNG-import Network.TLS.Record.Reading+import Network.TLS.Record.Recv+import Network.TLS.Record.Send import Network.TLS.Record.State-import Network.TLS.Record.Writing import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13-import Network.TLS.Types (Role (..))+import Network.TLS.Types (+ Role (..),+ TranscriptHash (..),+ defaultRecordSizeLimit,+ ) import Network.TLS.X509 class TLSParams a where getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO ()- doHandshakeWith :: a -> Context -> Handshake -> IO ()+ doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool- doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO ()+ doPostHandshakeAuthWith :: a -> Context -> Handshake13R -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams =@@ -126,7 +140,7 @@ doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer- doPostHandshakeAuthWith = postHandshakeAuthServerWith+ doPostHandshakeAuthWith = \_ _ _ -> return () -- | create a new context using the backend and parameters specified. contextNew@@ -163,9 +177,11 @@ hs <- newMVar Nothing recvActionsRef <- newIORef [] sendActionRef <- newIORef Nothing- crs <- newIORef [] locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State+ mylimref <- newRecordLimitRef $ Just defaultRecordSizeLimit+ peerlimref <- newRecordLimitRef $ Just defaultRecordSizeLimit+ hpkeref <- newIORef Nothing let roleParams = RoleParams { doHandshake_ = doHandshake params@@ -179,8 +195,10 @@ { ctxBackend = getBackend backend , ctxShared = shared , ctxSupported = supported+ , ctxDebug = debug , ctxTLSState = tlsstate- , ctxFragmentSize = Just 16384+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxTxRecordState = tx , ctxRxRecordState = rx , ctxHandshakeState = hs@@ -193,22 +211,21 @@ , ctxLocks = locks , ctxPendingRecvActions = recvActionsRef , ctxPendingSendAction = sendActionRef- , ctxCertRequests = crs- , ctxKeyLogger = debugKeyLogger debug , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp , ctxQUICMode = False , ctxTLS13State = st13ref+ , ctxHPKE = hpkeref } syncNoOp _ _ = return () recordLayer = RecordLayer- { recordEncode = encodeRecord+ { recordEncode12 = encodeRecord12 , recordEncode13 = encodeRecord13 , recordSendBytes = sendBytes- , recordRecv = recvRecord+ , recordRecv12 = recvRecord12 , recordRecv13 = recvRecord13 } @@ -250,28 +267,36 @@ -- 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- then usingState_ ctx getFirstVerifyData+ -- 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+ Nothing -> return Nothing+ Just (VerifyData verifyData) -> return $ Just verifyData else return Nothing -- | Getting the "tls-exporter" channel binding for TLS 1.3 (RFC9266). -- 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 exporter :: Context -> ByteString -> ByteString -> Int -> IO (Maybe ByteString) exporter ctx label context outlen = do- msecret <- usingState_ ctx getExporterSecret+ msecret <- usingState_ ctx getTLS13ExporterSecret mcipher <- failOnEitherError $ runRxRecordState ctx $ gets stCipher return $ case (msecret, mcipher) of (Just secret, Just cipher) -> let h = cipherHash cipher- secret' = deriveSecret h secret label ""+ secret' = deriveSecret h secret label $ TranscriptHash "" label' = "exporter" value' = hash h context key = hkdfExpandLabel h secret' label' value' outlen
Network/TLS/Context/Internal.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Context.Internal (@@ -16,7 +15,9 @@ -- * Context object and accessor Context (..), Hooks (..),+ Limit (..), Established (..),+ PendingRecv (..), PendingRecvAction (..), RecordLayer (..), Locks (..),@@ -36,6 +37,7 @@ updateMeasure, withMeasure, withReadLock,+ tryWithReadLock, withWriteLock, withStateLock, withRWLock,@@ -57,8 +59,6 @@ restoreHState, getStateRNG, tls13orLater,- addCertRequest13,- getCertRequest13, decideRecordVersion, -- * Misc@@ -67,20 +67,39 @@ defaultTLS13State, getTLS13State, modifyTLS13State,+ incrementTLS13KeyUpdateCount,+ resetTLS13KeyUpdateCount, CipherChoice (..), makeCipherChoice,++ -- * RecordLimit+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef,++ -- * ECH+ HPKEF,+ getTLS13HPKE,+ setTLS13HPKE, ) where import Control.Concurrent.MVar-import Control.Exception (throwIO)+import qualified Control.Exception as E import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.IORef import Data.Tuple import Network.TLS.Backend import Network.TLS.Cipher-import Network.TLS.Compression (Compression) import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Control@@ -97,30 +116,16 @@ import Network.TLS.Types import Network.TLS.Util --- | Information related to a running context, e.g. current cipher-data Information = Information- { infoVersion :: Version- , infoCipher :: Cipher- , infoCompression :: Compression- , infoMainSecret :: Maybe ByteString- , infoExtendedMainSecret :: Bool- , infoClientRandom :: Maybe ClientRandom- , infoServerRandom :: Maybe ServerRandom- , infoSupportedGroup :: Maybe Group- , infoTLS12Resumption :: Bool- , infoTLS13HandshakeMode :: Maybe HandshakeMode13- , infoIsEarlyDataAccepted :: Bool- }- deriving (Show, Eq)- -- | A TLS Context keep tls specific state, parameters and backend information.-data Context = forall a.+data Context+ = forall a. Monoid a => Context { ctxBackend :: Backend -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared+ , ctxDebug :: DebugParams , ctxTLSState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool@@ -136,13 +141,11 @@ , ctxRoleParams :: RoleParams -- ^ hooks for this context , ctxLocks :: Locks- , ctxKeyLogger :: String -> IO () , ctxHooks :: IORef Hooks , -- TLS 1.3 ctxTLS13State :: IORef TLS13State , ctxPendingRecvActions :: IORef [PendingRecvAction] , ctxPendingSendAction :: IORef (Maybe (Context -> IO ()))- , ctxCertRequests :: IORef [Handshake13] -- ^ pending post handshake authentication requests , -- QUIC ctxRecordLayer :: RecordLayer a@@ -151,15 +154,27 @@ , -- Misc ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability.- , ctxFragmentSize :: Maybe Int- -- ^ maximum size of plaintext fragments+ , ctxMyRecordLimit :: IORef RecordLimit+ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3+ , ctxPeerRecordLimit :: IORef RecordLimit+ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3+ , ctxHPKE :: IORef (Maybe (HPKEF, Int)) } +type HPKEF = ByteString -> ByteString -> IO ByteString++data RecordLimit+ = NoRecordLimit -- for QUIC+ | RecordLimit+ Int -- effective+ (Maybe Int) -- pending+ deriving (Eq, Show)+ data RoleParams = RoleParams { doHandshake_ :: Context -> IO ()- , doHandshakeWith_ :: Context -> Handshake -> IO ()+ , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool- , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO ()+ , doPostHandshakeAuthWith_ :: Context -> Handshake13R -> IO () } data Locks = Locks@@ -176,7 +191,7 @@ { cVersion :: Version , cCipher :: Cipher , cHash :: Hash- , cZero :: ByteString+ , cZero :: Secret } deriving (Show) @@ -184,15 +199,16 @@ makeCipherChoice ver cipher = CipherChoice ver cipher h zero where h = cipherHash cipher- zero = B.replicate (hashDigestSize h) 0+ zero = BA.replicate (hashDigestSize h) 0 data TLS13State = TLS13State { tls13stRecvNST :: Bool -- client+ , tls13stKeyUpdateCount :: Int , 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@@ -200,6 +216,7 @@ , tls13stClientExtensions :: [ExtensionRaw] -- client , tls13stChoice :: ~CipherChoice -- client , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client+ -- Actual session id for TLS 1.2, random value for TLS 1.3 , tls13stSession :: Session , tls13stSentExtensions :: [ExtensionID] }@@ -208,11 +225,12 @@ defaultTLS13State = TLS13State { tls13stRecvNST = False+ , tls13stKeyUpdateCount = 0 , tls13stSentClientCert = False , tls13stRecvSF = False , tls13stSentCF = False , tls13stRecvCF = False- , tls13stPendingRecvData = Nothing+ , tls13stPendingRecv = NoPendingRecv , tls13stPendingSentData = id , tls13stRTT = 0 , tls13st0RTT = False@@ -230,6 +248,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 ())@@ -238,11 +266,11 @@ {- FOURMOLU_DISABLE -} data RecordLayer a = RecordLayer { -- Writing.hs- recordEncode :: Context -> Record Plaintext -> IO (Either TLSError a)+ recordEncode12 :: Context -> Record Plaintext -> IO (Either TLSError a) , recordEncode13 :: Context -> Record Plaintext -> IO (Either TLSError a) , recordSendBytes :: Context -> a -> IO () , -- Reading.hs- recordRecv :: Context -> Int -> IO (Either TLSError (Record Plaintext))+ recordRecv12 :: Context -> IO (Either TLSError (Record Plaintext)) , recordRecv13 :: Context -> IO (Either TLSError (Record Plaintext)) } {- FOURMOLU_ENABLE -}@@ -259,12 +287,24 @@ | 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 ())+ | PendingRecvActionSelfUpdate Bool (Handshake13R -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment.- PendingRecvActionHash Bool (ByteString -> Handshake13 -> IO ())+ PendingRecvActionHash+ Bool+ (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx)@@ -285,7 +325,7 @@ contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx- let (ms, ems, cr, sr, hm13, grp) =+ let (ms, ems, cr, sr, hm13, grp, ech) = case hstate of Just st -> ( hstMainSecret st@@ -294,19 +334,33 @@ , hstServerRandom st , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing , hstSupportedGroup st+ , hstTLS13ECHAccepted st )- Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing)+ Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing, False) (cipher, comp) <- readMVar (ctxRxRecordState ctx) <&> \st -> (stCipher st, stCompression st) let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False- tls12resumption <- usingState_ ctx isSessionResuming+ tls12resumption <- usingState_ ctx getTLS12SessionResuming case (ver, cipher) of (Just v, Just c) -> return $ Just $- Information v c comp ms ems cr sr grp tls12resumption hm13 accepted+ Information+ { infoVersion = v+ , infoCipher = c+ , infoCompression = comp+ , infoMainSecret = convert <$> ms+ , infoExtendedMainSecret = ems+ , infoClientRandom = cr+ , infoServerRandom = sr+ , infoSupportedGroup = grp+ , infoTLS12Resumption = tls12resumption+ , infoTLS13HandshakeMode = hm13+ , infoIsEarlyDataAccepted = accepted+ , infoIsECHAccepted = ech+ } _ -> return Nothing contextSend :: Context -> ByteString -> IO ()@@ -329,7 +383,7 @@ ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()-contextModifyHooks ctx = modifyIORef (ctxHooks ctx)+contextModifyHooks ctx = modifyIORef' (ctxHooks ctx) setEstablished :: Context -> Established -> IO () setEstablished ctx = writeIORef (ctxEstablished_ ctx)@@ -338,7 +392,7 @@ 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@@ -358,7 +412,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)@@ -421,6 +475,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) @@ -437,17 +511,66 @@ Left _ -> False Right v -> v >= TLS13 -addCertRequest13 :: Context -> Handshake13 -> IO ()-addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq :)+-------------------------------- -getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13)-getCertRequest13 ctx context = do- let ref = ctxCertRequests ctx- l <- readIORef ref- let (matched, others) = partition (\cr -> context == fromCertRequest13 cr) l- case matched of- [] -> return Nothing- (certReq : _) -> writeIORef ref others >> return (Just certReq)+setMyRecordLimit :: Context -> Maybe Int -> IO ()+setMyRecordLimit ctx msiz = modifyIORef' (ctxMyRecordLimit ctx) change where- fromCertRequest13 (CertRequest13 c _) = c- fromCertRequest13 _ = error "fromCertRequest13"+ change (RecordLimit n _) = RecordLimit n msiz+ change x = x++enableMyRecordLimit :: Context -> IO ()+enableMyRecordLimit ctx = modifyIORef' (ctxMyRecordLimit ctx) change+ where+ change (RecordLimit _ (Just n)) = RecordLimit n Nothing+ change x = x++getMyRecordLimit :: Context -> IO (Maybe Int)+getMyRecordLimit ctx = change <$> readIORef (ctxMyRecordLimit ctx)+ where+ change NoRecordLimit = Nothing+ change (RecordLimit n _) = Just n++checkMyRecordLimit :: Context -> IO Bool+checkMyRecordLimit ctx = chk <$> readIORef (ctxMyRecordLimit ctx)+ where+ chk NoRecordLimit = False+ chk (RecordLimit _ mx) = isJust mx++--------------------------------++setPeerRecordLimit :: Context -> Maybe Int -> IO ()+setPeerRecordLimit ctx msiz = modifyIORef' (ctxPeerRecordLimit ctx) change+ where+ change (RecordLimit n _) = RecordLimit n msiz+ change x = x++enablePeerRecordLimit :: Context -> IO ()+enablePeerRecordLimit ctx = modifyIORef' (ctxPeerRecordLimit ctx) change+ where+ change (RecordLimit _ (Just n)) = RecordLimit n Nothing+ change x = x++getPeerRecordLimit :: Context -> IO (Maybe Int)+getPeerRecordLimit ctx = change <$> readIORef (ctxPeerRecordLimit ctx)+ where+ change NoRecordLimit = Nothing+ change (RecordLimit n _) = Just n++checkPeerRecordLimit :: Context -> IO Bool+checkPeerRecordLimit ctx = chk <$> readIORef (ctxPeerRecordLimit ctx)+ where+ chk NoRecordLimit = False+ chk (RecordLimit _ mx) = isJust mx++newRecordLimitRef :: Maybe Int -> IO (IORef RecordLimit)+newRecordLimitRef Nothing = newIORef NoRecordLimit+newRecordLimitRef (Just n) = newIORef $ RecordLimit n Nothing++--------------------------------++setTLS13HPKE :: Context -> HPKEF -> Int -> IO ()+setTLS13HPKE ctx func nenc = writeIORef (ctxHPKE ctx) $ Just (func, nenc)++getTLS13HPKE :: Context -> IO (Maybe (HPKEF, Int))+getTLS13HPKE ctx = readIORef $ ctxHPKE ctx
Network/TLS/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} @@ -26,9 +27,9 @@ requestCertificate, ) where -import Control.Concurrent+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar import qualified Control.Exception as E-import Control.Monad (unless, void, when) import Control.Monad.State.Strict import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8@@ -36,19 +37,21 @@ import Data.IORef import System.Timeout -import Network.TLS.Cipher import Network.TLS.Context-import Network.TLS.Crypto+import Network.TLS.Context.Internal (+ incrementTLS13KeyUpdateCount,+ resetTLS13KeyUpdateCount,+ ) import Network.TLS.Extension import Network.TLS.Handshake import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Process-import Network.TLS.Handshake.Random+import Network.TLS.Handshake.Server import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO-import Network.TLS.KeySchedule+import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.PostHandshake import Network.TLS.Session@@ -57,8 +60,6 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types (- AnyTrafficSecret (..),- ApplicationSecret, HostName, Role (..), )@@ -77,11 +78,39 @@ sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx when (role == ClientRole && tls13 && sentClientCert) $ do rtt <- getRTT ctx- -- This 'timeout' should work.- mdat <- timeout rtt $ recvData 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@@ -92,11 +121,23 @@ let rtt' = max (fromIntegral rtt) 10 return (rtt' * rttFactor * 1000) -- ms to us --- | notify the context that this side wants to close connection.--- this is important that it is called before closing the handle, otherwise+-- | Notify the context that this side wants to close connection.+-- This is important that it is called before closing the handle, otherwise -- the session might not be resumable (for version < TLS1.2).+-- This doesn't actually close the handle. ----- this doesn't actually close the handle+-- Proper usage is as follows:+--+-- > ctx <- contextNew <backend> <params>+-- > handshake ctx+-- > ...+-- > bye+--+-- The following code ensures nothing but is no harm.+--+-- > bracket (contextNew <backend> <params>) bye $ \ctx -> do+-- > handshake ctx+-- > ... bye :: MonadIO m => Context -> m () bye ctx = liftIO $ do eof <- ctxEOF ctx@@ -111,10 +152,7 @@ recvNST <- chk unless recvNST $ do rtt <- getRTT ctx- var <- newEmptyMVar- _ <- forkIOWithUnmask $ \umask ->- umask (void $ timeout rtt $ recvHS13 ctx chk) `E.finally` putMVar var ()- takeMVar var+ tryRecvHS13 rtt chk else do -- receiving Client Finished let chk = tls13stRecvCF <$> getTLS13State ctx@@ -123,11 +161,28 @@ -- no chance to measure RTT before receiving CF -- fixme: 1sec is good enough? let rtt = 1000000- var <- newEmptyMVar- _ <- forkIOWithUnmask $ \umask ->- umask (void $ timeout rtt $ recvHS13 ctx chk) `E.finally` putMVar var ()- takeMVar var+ 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@@ -144,7 +199,7 @@ -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon.-getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)+getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol -- | If the Server Name Indication extension has been used, return the@@ -187,12 +242,12 @@ -- 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.- let len = ctxFragmentSize ctx- mapM_ (mapChunks_ len sendP) (L.toChunks dataToSend)+ mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3+ mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received. An empty result means EOF.-recvData :: MonadIO m => Context -> m B.ByteString+recvData :: MonadIO m => Context -> m ByteString recvData ctx = liftIO $ do tls13 <- tls13orLater ctx withReadLock ctx $ do@@ -206,15 +261,15 @@ -- will impact the validity of the context. if tls13 then recvData13 ctx else recvData12 ctx -recvData12 :: Context -> IO B.ByteString+recvData12 :: Context -> IO ByteString recvData12 ctx = do pkt <- recvPacket12 ctx either (onError terminate12) process pkt where- process (Handshake [ch@ClientHello{}]) =- handshakeWith ctx ch >> recvData12 ctx- process (Handshake [hr@HelloRequest]) =- handshakeWith ctx hr >> recvData12 ctx+ process (Handshake [ch@ClientHello{}] [b]) =+ handshakeWith ctx (ch, b) >> recvData12 ctx+ process (Handshake [hr@HelloRequest] [b]) =+ handshakeWith ctx (hr, b) >> recvData12 ctx -- UserCanceled should be followed by a close_notify. -- fixme: is it safe to call recvData12? process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty@@ -231,23 +286,28 @@ -- when receiving empty appdata, we just retry to get some data. process (AppData "") = recvData12 ctx process (AppData x) = return x- process p =+ process p = do let reason = "unexpected message " ++ show p- in terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason terminate12 = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) -recvData13 :: Context -> IO B.ByteString+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}+ -- 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@@ -259,8 +319,8 @@ ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc) )- process (Handshake13 hs) = do- loopHandshake13 hs+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. process (AppData13 "") = recvData13 ctx@@ -279,10 +339,10 @@ | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x"- | otherwise ->+ | otherwise -> do let reason = "early data deprotect overflow"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Established -> return x+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ Established -> resetTLS13KeyUpdateCount ctx >> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do established <- ctxEstablished ctx@@ -291,42 +351,52 @@ else do let reason = "CSS after Finished" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- process p =+ process p = do let reason = "unexpected message " ++ show p- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment.- loopHandshake13 (NewSessionTicket13 life add nonce label exts : hs) = do+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole- unless (role == ClientRole) $+ unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager). withWriteLock ctx $ do Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret (_, usedCipher, _, _) <- getTxRecordState ctx+ -- mMaxSize is always Just, but anyway+ let extract (EarlyDataIndication mMaxSize) =+ maybe 0 (fromIntegral . safeNonNegative32) mMaxSize let choice = makeCipherChoice TLS13 usedCipher psk = derivePSK choice resumptionSecret nonce- maxSize = case extensionLookup EID_EarlyData exts- >>= extensionDecode MsgTNewSessionTicket of- Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms- _ -> 0+ maxSize =+ lookupAndDecode+ EID_EarlyData+ MsgTNewSessionTicket+ exts+ 0+ extract life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk- let label' = B.copy label- void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata+ let ticket' = B.copy ticket+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}- loopHandshake13 hs- loopHandshake13 (KeyUpdate13 mode : hs) = do+ loopHandshake13 hbs+ loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do+ let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs+ when multipleKeyUpdate $ do+ let reason = "Multiple KeyUpdate is not allowed in one record"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- checkAlignment ctx hs+ checkAlignment ctx established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal.@@ -334,32 +404,38 @@ -- 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]+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] keyUpdate ctx getTxRecordState setTxRecordState- loopHandshake13 hs+ loopHandshake13 hbs else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- loopHandshake13 (h@CertRequest13{} : hs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hs- loopHandshake13 (h@Certificate13{} : hs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hs- loopHandshake13 (h : hs) = do+ -- Client only+ loopHandshake13 (hb@(CertRequest13{}, _) : hbs) =+ postHandshakeAuthWith ctx hb >> loopHandshake13 hbs+ loopHandshake13 (hb@(h, _) : hbs) = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of- ServerHello13 srand _ _ _ ->- when (isHelloRetryRequest srand) $ do+ ServerHello13 SH{..} ->+ when (isHelloRetryRequest shRandom) $ do clearTxRecordState ctx let reason = "HRR is not allowed for 0-RTT"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return ()- cont <- popAction ctx h hs- when cont $ loopHandshake13 hs+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do@@ -370,8 +446,8 @@ -- UserCanceled MUST be followed by a CloseNotify. process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx- process (Handshake13 hs) = do- loopHandshake13 hs+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs stop <- breakLoop unless stop $ recvHS13 ctx breakLoop process _ = recvHS13 ctx breakLoop@@ -379,11 +455,11 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment.- loopHandshake13 (NewSessionTicket13 life add nonce label exts : hs) = do+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole- unless (role == ClientRole) $+ unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager).@@ -392,27 +468,30 @@ (_, usedCipher, _, _) <- getTxRecordState ctx let choice = makeCipherChoice TLS13 usedCipher psk = derivePSK choice resumptionSecret nonce- maxSize = case extensionLookup EID_EarlyData exts- >>= extensionDecode MsgTNewSessionTicket of- Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms- _ -> 0+ maxSize =+ lookupAndDecode+ EID_EarlyData+ MsgTNewSessionTicket+ exts+ 0+ (\(EarlyDataIndication mms) -> fromIntegral $ safeNonNegative32 $ fromJust mms) life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk- let label' = B.copy label- void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata+ let ticket' = B.copy ticket+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}- loopHandshake13 hs- loopHandshake13 (h : hs) = do- cont <- popAction ctx h hs- when cont $ loopHandshake13 hs+ loopHandshake13 hbs+ loopHandshake13 (hb : hbs) = do+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool-popAction ctx h hs = do+popAction :: Context -> Handshake13R -> IO Bool+popAction ctx hb@(h, _b) = do mPendingRecvAction <- popPendingRecvAction ctx case mPendingRecvAction of Nothing -> return False@@ -423,13 +502,16 @@ handleException ctx $ do case action of PendingRecvAction needAligned pa -> do- when needAligned $ checkAlignment ctx hs- processHandshake13 ctx h+ when needAligned $ checkAlignment ctx+ updateTranscriptHash13 ctx hb pa h+ PendingRecvActionSelfUpdate needAligned pa -> do+ when needAligned $ checkAlignment ctx+ pa hb PendingRecvActionHash needAligned pa -> do- when needAligned $ checkAlignment ctx hs- d <- transcriptHash ctx- processHandshake13 ctx h+ 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.@@ -438,12 +520,12 @@ sendCFifNecessary ctx return True -checkAlignment :: Context -> [Handshake13] -> IO ()-checkAlignment ctx hs = do+checkAlignment :: Context -> IO ()+checkAlignment ctx = do complete <- isRecvComplete ctx- unless (complete && null hs) $+ unless complete $ do let reason = "received message not aligned with record boundary"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions@@ -452,15 +534,16 @@ onError :: Monad m- => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)+ => (TLSError -> AlertLevel -> AlertDescription -> String -> m ByteString) -> TLSError- -> m B.ByteString+ -> m ByteString onError _ Error_EOF = -- Not really an error. return B.empty-onError terminate err =- let (lvl, ad) = errorToAlert err- in terminate err lvl ad (errorToAlertMessage err)+onError terminate err = terminate err lvl ad reason+ where+ (lvl, ad) = errorToAlert err+ reason = errorToAlertMessage err terminateWithWriteLock :: Context@@ -470,16 +553,22 @@ -> AlertDescription -> String -> IO a-terminateWithWriteLock ctx send err level desc reason = do- session <- usingState_ ctx getSession- -- Session manager is always invoked with read+write locks, so we merge this- -- with the alert packet being emitted.- withWriteLock ctx $ do+terminateWithWriteLock ctx send err level desc reason = withWriteLock ctx $ do+ tls13 <- tls13orLater ctx+ unless tls13 $ do+ -- TLS 1.2 uses the same session ID and session data+ -- for all resumed sessions.+ --+ -- TLS 1.3 changes session data for every resumed session.+ session <- usingState_ ctx getSession case session of Session Nothing -> return ()- Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid- catchException (send [(level, desc)]) (\_ -> return ())+ Session (Just sid) ->+ -- calling even session ticket manager anyway+ sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid+ catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx+ debugError (ctxDebug ctx) reason E.throwIO (Terminated False reason err) {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}@@ -487,45 +576,3 @@ -- | same as recvData but returns a lazy bytestring. recvData' :: MonadIO m => Context -> m L.ByteString recvData' ctx = L.fromChunks . (: []) <$> recvData ctx--keyUpdate- :: Context- -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))- -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())- -> IO ()-keyUpdate ctx getState setState = do- (usedHash, usedCipher, level, applicationSecretN) <- getState ctx- unless (level == CryptApplicationSecret) $- throwCore $- Error_Protocol- "tried key update without application traffic secret"- InternalError- let applicationSecretN1 =- hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $- hashDigestSize usedHash- setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)---- | How to update keys in TLS 1.3-data KeyUpdateRequest- = -- | Unidirectional key update- OneWay- | -- | Bidirectional key update (normal case)- 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.-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
Network/TLS/Credentials.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Network.TLS.Credentials ( Credential,@@ -15,14 +16,14 @@ ) where import Data.X509+import qualified Data.X509 as X509 import Data.X509.File import Data.X509.Memory+ import Network.TLS.Crypto import Network.TLS.Imports-import Network.TLS.X509--import qualified Data.X509 as X509 import qualified Network.TLS.Struct as TLS+import Network.TLS.X509 type Credential = (CertificateChain, PrivKey)
Network/TLS/Crypto.hs view
@@ -7,6 +7,7 @@ HashCtx, hashInit, hashUpdate,+ hashUpdates, hashUpdateSSL, hashFinal, module Network.TLS.Crypto.DH,@@ -15,6 +16,7 @@ -- * Hash hash,+ hashChunks, Hash (..), hashName, hashDigestSize,@@ -56,9 +58,13 @@ import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random-import qualified Data.ByteArray as B (convert)+import Data.ASN1.BinaryEncoding (BER (..), DER (..))+import Data.ASN1.Encoding+import Data.ASN1.Types+import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B-+import Data.Proxy import Data.X509 ( PrivKey (..), PrivKeyEC (..),@@ -67,16 +73,13 @@ SerializedPoint (..), ) import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint)+ import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types import Network.TLS.Imports -import Data.ASN1.BinaryEncoding (BER (..), DER (..))-import Data.ASN1.Encoding-import Data.ASN1.Types--import Data.Proxy+---------------------------------------------------------------- {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey@@ -115,7 +118,9 @@ pg (DH.Params p g _) = (p, g) table =- [ (pg prms, grp) | grp <- availableFFGroups, let prms = fromJust $ dhParamsForGroup grp+ [ (pg prms, grp)+ | grp <- availableFFGroups+ , let prms = fromJust $ dhParamsForGroup grp ] findEllipticCurveGroup :: PubKeyEC -> Maybe Group@@ -136,24 +141,32 @@ hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512) hashInit SHA1_MD5 = HashContextSSL H.hashInit H.hashInit -hashUpdate :: HashContext -> B.ByteString -> HashCtx+hashUpdate :: HashContext -> ByteString -> HashCtx hashUpdate (HashContext (ContextSimple h)) b = HashContext $ ContextSimple (H.hashUpdate h b) hashUpdate (HashContextSSL sha1Ctx md5Ctx) b = HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b) +hashUpdates :: HashContext -> [ByteString] -> HashCtx+hashUpdates (HashContext (ContextSimple h)) xs = HashContext $ ContextSimple (H.hashUpdates h xs)+hashUpdates (HashContextSSL sha1Ctx md5Ctx) xs =+ HashContextSSL (H.hashUpdates sha1Ctx xs) (H.hashUpdates md5Ctx xs)++hashChunks :: Hash -> [ByteString] -> ByteString+hashChunks h xs = hashFinal $ hashUpdates (hashInit h) xs+ hashUpdateSSL :: HashCtx- -> (B.ByteString, B.ByteString)+ -> (ByteString, ByteString) -- ^ (for the md5 context, for the sha1 context) -> HashCtx hashUpdateSSL (HashContext _) _ = error "internal error: update SSL without a SSL Context" hashUpdateSSL (HashContextSSL sha1Ctx md5Ctx) (b1, b2) = HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) -hashFinal :: HashCtx -> B.ByteString-hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h+hashFinal :: HashCtx -> ByteString+hashFinal (HashContext (ContextSimple h)) = convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) =- B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)]+ B.concat [convert (H.hashFinalize md5Ctx), convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 deriving (Show, Eq)@@ -170,20 +183,14 @@ type HashCtx = HashContext -hash :: Hash -> B.ByteString -> B.ByteString-hash MD5 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.MD5) $ b-hash SHA1 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA1) $ b-hash SHA224 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA224) $ b-hash SHA256 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA256) $ b-hash SHA384 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA384) $ b-hash SHA512 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA512) $ b-hash SHA1_MD5 b =- B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)]- where- sha1Hash :: B.ByteString -> H.Digest H.SHA1- sha1Hash = H.hash- md5Hash :: B.ByteString -> H.Digest H.MD5- md5Hash = H.hash+hash :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba+hash MD5 b = convert (H.hash b :: H.Digest H.MD5)+hash SHA1 b = convert (H.hash b :: H.Digest H.SHA1)+hash SHA224 b = convert (H.hash b :: H.Digest H.SHA224)+hash SHA256 b = convert (H.hash b :: H.Digest H.SHA256)+hash SHA384 b = convert (H.hash b :: H.Digest H.SHA384)+hash SHA512 b = convert (H.hash b :: H.Digest H.SHA512)+hash SHA1_MD5 b = BA.concat [hash MD5 b, hash SHA1 b] hashName :: Hash -> String hashName = show@@ -214,12 +221,12 @@ generalizeRSAError (Right x) = Right x kxEncrypt- :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString)+ :: MonadRandom r => PublicKey -> ScrubbedBytes -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt- :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString)+ :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ScrubbedBytes) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) @@ -356,9 +363,9 @@ Just sign -> Right (ECDSA.signatureToIntegers prx sign) unsupported = return $ Left KxUnsupported kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg =- return $ Right $ B.convert $ Ed25519.sign pk pub msg+ return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg =- return $ Right $ B.convert $ Ed448.sign pk pub msg+ return $ Right $ convert $ Ed448.sign pk pub msg kxSign _ _ _ _ = return (Left KxUnsupported) @@ -424,6 +431,8 @@ kxSupportedPrivKeyEC privkey = case ecPrivKeyCurveName privkey of Just ECC.SEC_p256r1 -> True+ Just ECC.SEC_p384r1 -> True+ Just ECC.SEC_p521r1 -> True _ -> False -- Perform a public-key operation with a parameterized ECC implementation when@@ -444,6 +453,10 @@ Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> maybeCryptoError $ withProxy p256 <$> ECDSA.decodePublic p256 bs+ Just ECC.SEC_p384r1 ->+ maybeCryptoError $ withProxy p384 <$> ECDSA.decodePublic p384 bs+ Just ECC.SEC_p521r1 ->+ maybeCryptoError $ withProxy p521 <$> ECDSA.decodePublic p521 bs Just curveName -> let curve = ECC.getCurveByName curveName pub = unserializePoint curve pt@@ -473,9 +486,17 @@ -- using ECDSA.decodePrivate, unfortunately the data type chosen in -- x509 was Integer. maybeCryptoError $ withProxy p256 <$> ECDSA.scalarFromInteger p256 d+ Just ECC.SEC_p384r1 ->+ maybeCryptoError $ withProxy p384 <$> ECDSA.scalarFromInteger p384 d+ Just ECC.SEC_p521r1 ->+ maybeCryptoError $ withProxy p521 <$> ECDSA.scalarFromInteger p521 d Just curveName -> Just $ withUnsupported curveName where d = privkeyEC_priv privkey p256 :: Proxy ECDSA.Curve_P256R1 p256 = Proxy+p384 :: Proxy ECDSA.Curve_P384R1+p384 = Proxy+p521 :: Proxy ECDSA.Curve_P521R1+p521 = Proxy
Network/TLS/Crypto/DH.hs view
@@ -21,13 +21,15 @@ import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH-import qualified Data.ByteArray as B+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA+ import Network.TLS.RNG type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params-type DHKey = DH.SharedKey+type DHKey = ScrubbedBytes dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber@@ -45,12 +47,12 @@ return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey-dhGetShared params priv pub =- stripLeadingZeros (DH.getShared params priv pub)+dhGetShared params priv pub = stripLeadingZeros sec where+ DH.SharedKey sec = DH.getShared params priv pub -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.- stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb)+ stripLeadingZeros sb = snd $ BA.span (== 0) sb -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.
Network/TLS/Crypto/IES.hs view
@@ -1,20 +1,25 @@--- |+-- | (Elliptic Curve) Integrated Encryption Scheme+-- KEM(Key Encapsulation Mechanism) based APIs+-- -- Module : Network.TLS.Crypto.IES -- License : BSD-style -- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp> -- Stability : experimental -- Portability : unknown module Network.TLS.Crypto.IES (- GroupPublic,+ GroupPublicA,+ GroupPublicB, GroupPrivate, GroupKey, -- * Group methods groupGenerateKeyPair,- groupGetPubShared,- groupGetShared,- encodeGroupPublic,- decodeGroupPublic,+ groupEncapsulate,+ groupDecapsulate,+ groupEncodePublicA,+ groupDecodePublicA,+ groupEncodePublicB,+ groupDecodePublicB, -- * Compatibility with 'Network.TLS.Crypto.DH' dhParamsForGroup,@@ -23,19 +28,25 @@ ) where import Control.Arrow-import Crypto.ECC+import Crypto.ECC as ECC import Crypto.Error import Crypto.Number.Generate-import Crypto.PubKey.DH hiding (generateParams)+import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..))+import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES-import qualified Data.ByteArray as B+import Crypto.PubKey.ML_KEM (ML_KEM_1024, ML_KEM_512, ML_KEM_768)+import qualified Crypto.PubKey.ML_KEM as ML+import Data.ByteArray (ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import Data.Proxy+ import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Util.Serialization (i2ospOf_, os2ip) +{- FOURMOLU_DISABLE -} data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) | GroupPri_P384 (Scalar Curve_P384R1)@@ -47,23 +58,59 @@ | GroupPri_FFDHE4096 PrivateNumber | GroupPri_FFDHE6144 PrivateNumber | GroupPri_FFDHE8192 PrivateNumber+ | GroupPri_MLKEM512 (ML.DecapsulationKey ML_KEM_512)+ | GroupPri_MLKEM768 (ML.DecapsulationKey ML_KEM_768)+ | GroupPri_MLKEM1024 (ML.DecapsulationKey ML_KEM_1024)+ | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey ML_KEM_768)+ | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey ML_KEM_768)+ | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey ML_KEM_1024) deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -data GroupPublic- = GroupPub_P256 (Point Curve_P256R1)- | GroupPub_P384 (Point Curve_P384R1)- | GroupPub_P521 (Point Curve_P521R1)- | GroupPub_X255 (Point Curve_X25519)- | GroupPub_X448 (Point Curve_X448)- | GroupPub_FFDHE2048 PublicNumber- | GroupPub_FFDHE3072 PublicNumber- | GroupPub_FFDHE4096 PublicNumber- | GroupPub_FFDHE6144 PublicNumber- | GroupPub_FFDHE8192 PublicNumber+{- FOURMOLU_DISABLE -}+data GroupPublicA+ = GroupPubA_P256 (Point Curve_P256R1)+ | GroupPubA_P384 (Point Curve_P384R1)+ | GroupPubA_P521 (Point Curve_P521R1)+ | GroupPubA_X255 (Point Curve_X25519)+ | GroupPubA_X448 (Point Curve_X448)+ | GroupPubA_FFDHE2048 PublicNumber+ | GroupPubA_FFDHE3072 PublicNumber+ | GroupPubA_FFDHE4096 PublicNumber+ | GroupPubA_FFDHE6144 PublicNumber+ | GroupPubA_FFDHE8192 PublicNumber+ | GroupPubA_MLKEM512 (ML.EncapsulationKey ML_KEM_512)+ | GroupPubA_MLKEM768 (ML.EncapsulationKey ML_KEM_768)+ | GroupPubA_MLKEM1024 (ML.EncapsulationKey ML_KEM_1024)+ | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey ML_KEM_768)+ | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey ML_KEM_768)+ | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey ML_KEM_1024) deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -type GroupKey = SharedSecret+{- FOURMOLU_DISABLE -}+data GroupPublicB+ = GroupPubB_P256 (Point Curve_P256R1)+ | GroupPubB_P384 (Point Curve_P384R1)+ | GroupPubB_P521 (Point Curve_P521R1)+ | GroupPubB_X255 (Point Curve_X25519)+ | GroupPubB_X448 (Point Curve_X448)+ | GroupPubB_FFDHE2048 PublicNumber+ | GroupPubB_FFDHE3072 PublicNumber+ | GroupPubB_FFDHE4096 PublicNumber+ | GroupPubB_FFDHE6144 PublicNumber+ | GroupPubB_FFDHE8192 PublicNumber+ | GroupPubB_MLKEM512 (ML.Ciphertext ML_KEM_512)+ | GroupPubB_MLKEM768 (ML.Ciphertext ML_KEM_768)+ | GroupPubB_MLKEM1024 (ML.Ciphertext ML_KEM_1024)+ | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext ML_KEM_768)+ | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext ML_KEM_768)+ | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext ML_KEM_1024)+ deriving (Eq, Show)+{- FOURMOLU_ENABLE -} +type GroupKey = ScrubbedBytes+ p256 :: Proxy Curve_P256R1 p256 = Proxy @@ -79,7 +126,16 @@ x448 :: Proxy Curve_X448 x448 = Proxy -dhParamsForGroup :: Group -> Maybe Params+mlkem512 :: Proxy ML_KEM_512+mlkem512 = Proxy++mlkem768 :: Proxy ML_KEM_768+mlkem768 = Proxy++mlkem1024 :: Proxy ML_KEM_1024+mlkem1024 = Proxy++dhParamsForGroup :: Group -> Maybe DH.Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096@@ -87,26 +143,47 @@ dhParamsForGroup FFDHE8192 = Just ffdhe8192 dhParamsForGroup _ = Nothing -groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic)+groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublicA) groupGenerateKeyPair P256 =- (GroupPri_P256, GroupPub_P256) `fs` curveGenerateKeyPair p256+ (GroupPri_P256, GroupPubA_P256) `fs` curveGenerateKeyPair p256 groupGenerateKeyPair P384 =- (GroupPri_P384, GroupPub_P384) `fs` curveGenerateKeyPair p384+ (GroupPri_P384, GroupPubA_P384) `fs` curveGenerateKeyPair p384 groupGenerateKeyPair P521 =- (GroupPri_P521, GroupPub_P521) `fs` curveGenerateKeyPair p521+ (GroupPri_P521, GroupPubA_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 =- (GroupPri_X255, GroupPub_X255) `fs` curveGenerateKeyPair x25519+ (GroupPri_X255, GroupPubA_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 =- (GroupPri_X448, GroupPub_X448) `fs` curveGenerateKeyPair x448-groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048-groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072-groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096-groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144-groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192+ (GroupPri_X448, GroupPubA_X448) `fs` curveGenerateKeyPair x448+groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPubA_FFDHE2048+groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPubA_FFDHE3072+groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPubA_FFDHE4096+groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPubA_FFDHE6144+groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPubA_FFDHE8192+groupGenerateKeyPair MLKEM512 = do+ (e, d) <- ML.generate mlkem512+ return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e)+groupGenerateKeyPair MLKEM768 = do+ (e, d) <- ML.generate mlkem768+ return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e)+groupGenerateKeyPair MLKEM1024 = do+ (e, d) <- ML.generate mlkem1024+ return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e)+groupGenerateKeyPair X25519MLKEM768 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair x25519+ (e2, d2) <- ML.generate mlkem768+ return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2))+groupGenerateKeyPair P256MLKEM768 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair p256+ (e2, d2) <- ML.generate mlkem768+ return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2))+groupGenerateKeyPair P384MLKEM1024 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair p384+ (e2, d2) <- ML.generate mlkem1024+ return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair" dhGroupGenerateKeyPair- :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber)+ :: MonadRandom r => Group -> r (DH.Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096)@@ -114,148 +191,332 @@ dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) -addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b)+addParams :: Functor f => DH.Params -> f (a, b) -> f (DH.Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b) fs :: MonadRandom r- => (Scalar a -> GroupPrivate, Point a -> GroupPublic)+ => (Scalar a -> GroupPrivate, Point a -> GroupPublicA) -> r (KeyPair a)- -> r (GroupPrivate, GroupPublic)+ -> r (GroupPrivate, GroupPublicA) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) +fs' :: Monad m => m (KeyPair curve) -> m (Scalar curve, Point curve)+fs' action = do+ keypair <- action+ let pub = keypairGetPublic keypair+ pri = keypairGetPrivate keypair+ return (pri, pub)+ gen :: MonadRandom r- => Params+ => DH.Params -> Int -> (PrivateNumber -> GroupPrivate)- -> (PublicNumber -> GroupPublic)- -> r (GroupPrivate, GroupPublic)+ -> (PublicNumber -> GroupPublicA)+ -> r (GroupPrivate, GroupPublicA) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits gen' :: MonadRandom r- => Params+ => DH.Params -> Int -> r (PrivateNumber, PublicNumber)-gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits+gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits -groupGetPubShared- :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey))-groupGetPubShared (GroupPub_P256 pub) =- fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub-groupGetPubShared (GroupPub_P384 pub) =- fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub-groupGetPubShared (GroupPub_P521 pub) =- fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub-groupGetPubShared (GroupPub_X255 pub) =- fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub-groupGetPubShared (GroupPub_X448 pub) =- fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub-groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048-groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072-groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096-groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144-groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192+groupEncapsulate+ :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey))+groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub+groupEncapsulate (GroupPubA_P384 pub) = getECDHPubShared GroupPubB_P384 p384 pub+groupEncapsulate (GroupPubA_P521 pub) = getECDHPubShared GroupPubB_P521 p521 pub+groupEncapsulate (GroupPubA_X255 pub) = getECDHPubShared GroupPubB_X255 x25519 pub+groupEncapsulate (GroupPubA_X448 pub) = getECDHPubShared GroupPubB_X448 x448 pub+groupEncapsulate (GroupPubA_FFDHE2048 pub) = getDHPubShared ffdhe2048 exp2048 pub GroupPubB_FFDHE2048+groupEncapsulate (GroupPubA_FFDHE3072 pub) = getDHPubShared ffdhe3072 exp3072 pub GroupPubB_FFDHE3072+groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096+groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144+groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192+groupEncapsulate (GroupPubA_MLKEM512 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM512 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM768 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM768 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM1024 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM1024 ct, convert sec)+-- 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)) = do+ mx <- getECDHPubShared' x25519 e1+ case mx of+ Nothing -> return Nothing+ Just (c1, k1) -> do+ (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+ mx <- getECDHPubShared' p256 e1+ case mx of+ Nothing -> return Nothing+ Just (c1, k1) -> do+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)+groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do+ mx <- getECDHPubShared' p384 e1+ case mx of+ Nothing -> return Nothing+ Just (c1, k1) -> do+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2) dhGroupGetPubShared- :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey))-dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub-dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub-dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub-dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub-dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub+ :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey))+dhGroupGetPubShared FFDHE2048 pub = getDHPubShared' ffdhe2048 exp2048 pub+dhGroupGetPubShared FFDHE3072 pub = getDHPubShared' ffdhe3072 exp3072 pub+dhGroupGetPubShared FFDHE4096 pub = getDHPubShared' ffdhe4096 exp4096 pub+dhGroupGetPubShared FFDHE6144 pub = getDHPubShared' ffdhe6144 exp6144 pub+dhGroupGetPubShared FFDHE8192 pub = getDHPubShared' ffdhe8192 exp8192 pub dhGroupGetPubShared _ _ = return Nothing -getPubShared+getECDHPubShared+ :: (MonadRandom m, EllipticCurveDH curve)+ => (Point curve -> GroupPublicB)+ -> proxy curve+ -> Point curve+ -> m (Maybe (GroupPublicB, GroupKey))+getECDHPubShared tag proxy pub = do+ mx <- maybeCryptoError <$> deriveEncrypt proxy pub+ case mx of+ Nothing -> return Nothing+ Just (p, ECC.SharedSecret s) -> return $ Just (tag p, s)++getECDHPubShared'+ :: (MonadRandom m, EllipticCurveDH curve)+ => proxy curve+ -> Point curve+ -> m (Maybe (Point curve, GroupKey))+getECDHPubShared' proxy pub = do+ mx <- maybeCryptoError <$> deriveEncrypt proxy pub+ case mx of+ Nothing -> return Nothing+ Just (p, ECC.SharedSecret s) -> return $ Just (p, s)++getDHPubShared :: MonadRandom r- => Params+ => DH.Params -> Int -> PublicNumber- -> (PublicNumber -> GroupPublic)- -> r (Maybe (GroupPublic, GroupKey))-getPubShared params expBits pub pubTag+ -> (PublicNumber -> GroupPublicB)+ -> r (Maybe (GroupPublicB, GroupKey))+getDHPubShared params expBits pub pubTag | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits- let mypub = calculatePublic params mypri- let SharedKey share = getShared params mypri pub- return $ Just (pubTag mypub, SharedSecret share)+ let mypub = DH.calculatePublic params mypri+ DH.SharedKey share = DH.getShared params mypri pub+ return $ Just (pubTag mypub, share) -getPubShared'+getDHPubShared' :: MonadRandom r- => Params+ => DH.Params -> Int -> PublicNumber- -> r (Maybe (PublicNumber, SharedKey))-getPubShared' params expBits pub+ -> r (Maybe (PublicNumber, GroupKey))+getDHPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits- let share = stripLeadingZeros (getShared params mypri pub)- return $ Just (calculatePublic params mypri, SharedKey share)+ let share = stripLeadingZeros (DH.getShared params mypri pub)+ return $ Just (DH.calculatePublic params mypri, convert share) -groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey-groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri-groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri-groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri-groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri-groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri-groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri-groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri-groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri-groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri-groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri-groupGetShared _ _ = Nothing+unwrap :: SharedSecret -> GroupKey+unwrap (ECC.SharedSecret sec) = sec -calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret-calcShared params pub pri- | valid params pub = Just $ SharedSecret share+groupDecapsulate :: GroupPublicB -> GroupPrivate -> Maybe GroupKey+groupDecapsulate (GroupPubB_P256 pub) (GroupPri_P256 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 pub pri+groupDecapsulate (GroupPubB_P384 pub) (GroupPri_P384 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 pub pri+groupDecapsulate (GroupPubB_P521 pub) (GroupPri_P521 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p521 pub pri+groupDecapsulate (GroupPubB_X255 pub) (GroupPri_X255 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 pub pri+groupDecapsulate (GroupPubB_X448 pub) (GroupPri_X448 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x448 pub pri+groupDecapsulate (GroupPubB_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcDHShared ffdhe2048 pub pri+groupDecapsulate (GroupPubB_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcDHShared ffdhe3072 pub pri+groupDecapsulate (GroupPubB_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcDHShared ffdhe4096 pub pri+groupDecapsulate (GroupPubB_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcDHShared ffdhe6144 pub pri+groupDecapsulate (GroupPubB_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcDHShared ffdhe8192 pub pri+groupDecapsulate (GroupPubB_MLKEM512 p) (GroupPri_MLKEM512 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_X25519MLKEM768 (p1, p2)) (GroupPri_X25519MLKEM768 (s1, s2)) = do+ bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 p1 s1+ let bs2 = convert $ ML.decapsulate s2 p2+ return (bs2 <> bs1)+groupDecapsulate (GroupPubB_P256MLKEM768 (p1, p2)) (GroupPri_P256MLKEM768 (s1, s2)) = do+ bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 p1 s1+ let bs2 = convert $ ML.decapsulate s2 p2+ return (bs1 <> bs2)+groupDecapsulate (GroupPubB_P384MLKEM1024 (p1, p2)) (GroupPri_P384MLKEM1024 (s1, s2)) = do+ bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 p1 s1+ let bs2 = convert $ ML.decapsulate s2 p2+ return (bs1 <> bs2)+groupDecapsulate _ _ = Nothing++calcDHShared :: DH.Params -> PublicNumber -> PrivateNumber -> Maybe GroupKey+calcDHShared params pub pri+ | valid params pub = Just $ convert share | otherwise = Nothing where- SharedKey share = getShared params pri pub+ share = DH.getShared params pri pub -encodeGroupPublic :: GroupPublic -> ByteString-encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p-encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p-encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p-encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p-encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p-encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p-encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p-encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p-encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p-encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA :: GroupPublicA -> ByteString+groupEncodePublicA (GroupPubA_P256 p) = encodePoint p256 p+groupEncodePublicA (GroupPubA_P384 p) = encodePoint p384 p+groupEncodePublicA (GroupPubA_P521 p) = encodePoint p521 p+groupEncodePublicA (GroupPubA_X255 p) = encodePoint x25519 p+groupEncodePublicA (GroupPubA_X448 p) = encodePoint x448 p+groupEncodePublicA (GroupPubA_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicA (GroupPubA_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicA (GroupPubA_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicA (GroupPubA_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicA (GroupPubA_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA (GroupPubA_MLKEM512 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM768 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM1024 p) = ML.encode p+groupEncodePublicA (GroupPubA_X25519MLKEM768 (p1, p2)) =+ ML.encode p2 <> encodePoint x25519 p1+groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) =+ encodePoint p256 p1 <> ML.encode p2+groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) =+ encodePoint p384 p1 <> ML.encode p2 -enc :: Params -> PublicNumber -> ByteString-enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p+groupEncodePublicB :: GroupPublicB -> ByteString+groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p+groupEncodePublicB (GroupPubB_P384 p) = encodePoint p384 p+groupEncodePublicB (GroupPubB_P521 p) = encodePoint p521 p+groupEncodePublicB (GroupPubB_X255 p) = encodePoint x25519 p+groupEncodePublicB (GroupPubB_X448 p) = encodePoint x448 p+groupEncodePublicB (GroupPubB_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicB (GroupPubB_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicB (GroupPubB_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicB (GroupPubB_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicB (GroupPubB_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicB (GroupPubB_MLKEM512 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM768 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM1024 p) = convert p+groupEncodePublicB (GroupPubB_X25519MLKEM768 (p1, p2)) =+ convert p2 <> encodePoint x25519 p1+groupEncodePublicB (GroupPubB_P256MLKEM768 (p1, p2)) =+ encodePoint p256 p1 <> convert p2+groupEncodePublicB (GroupPubB_P384MLKEM1024 (p1, p2)) =+ encodePoint p384 p1 <> convert p2 -decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic-decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs-decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs-decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs-decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs-decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs-decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs-decodeGroupPublic _ _ = error "decodeGroupPublic"+enc :: DH.Params -> PublicNumber -> ByteString+enc params (PublicNumber p) = i2ospOf_ ((DH.params_bits params + 7) `div` 8) p +groupDecodePublicA :: Group -> ByteString -> Either CryptoError GroupPublicA+groupDecodePublicA P256 bs = eitherCryptoError $ GroupPubA_P256 <$> decodePoint p256 bs+groupDecodePublicA P384 bs = eitherCryptoError $ GroupPubA_P384 <$> decodePoint p384 bs+groupDecodePublicA P521 bs = eitherCryptoError $ GroupPubA_P521 <$> decodePoint p521 bs+groupDecodePublicA X25519 bs = eitherCryptoError $ GroupPubA_X255 <$> decodePoint x25519 bs+groupDecodePublicA X448 bs = eitherCryptoError $ GroupPubA_X448 <$> decodePoint x448 bs+groupDecodePublicA FFDHE2048 bs = Right . GroupPubA_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE3072 bs = Right . GroupPubA_FFDHE3072 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE4096 bs = Right . GroupPubA_FFDHE4096 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE6144 bs = Right . GroupPubA_FFDHE6144 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE8192 bs = Right . GroupPubA_FFDHE8192 . PublicNumber $ os2ip bs+groupDecodePublicA MLKEM512 bs = case ML.decode mlkem512 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM512 p+groupDecodePublicA MLKEM768 bs = case ML.decode mlkem768 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM768 p+groupDecodePublicA MLKEM1024 bs = case ML.decode mlkem1024 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM1024 p+groupDecodePublicA X25519MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 1184 bs+ in case ML.decode mlkem768 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_X25519MLKEM768 (p2, p1)+groupDecodePublicA P256MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 65 bs+ in case ML.decode mlkem768 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_P256MLKEM768 (p2, p1)+groupDecodePublicA P384MLKEM1024 bs =+ let (bs1, bs2) = BA.splitAt 97 bs+ in case ML.decode mlkem1024 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_P384MLKEM1024 (p2, p1)+groupDecodePublicA _ _ = error "groupDecodePublicA"++groupDecodePublicB :: Group -> ByteString -> Either CryptoError GroupPublicB+groupDecodePublicB P256 bs = eitherCryptoError $ GroupPubB_P256 <$> decodePoint p256 bs+groupDecodePublicB P384 bs = eitherCryptoError $ GroupPubB_P384 <$> decodePoint p384 bs+groupDecodePublicB P521 bs = eitherCryptoError $ GroupPubB_P521 <$> decodePoint p521 bs+groupDecodePublicB X25519 bs = eitherCryptoError $ GroupPubB_X255 <$> decodePoint x25519 bs+groupDecodePublicB X448 bs = eitherCryptoError $ GroupPubB_X448 <$> decodePoint x448 bs+groupDecodePublicB FFDHE2048 bs = Right . GroupPubB_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE3072 bs = Right . GroupPubB_FFDHE3072 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE4096 bs = Right . GroupPubB_FFDHE4096 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE6144 bs = Right . GroupPubB_FFDHE6144 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE8192 bs = Right . GroupPubB_FFDHE8192 . PublicNumber $ os2ip bs+groupDecodePublicB MLKEM512 bs = case ML.decode mlkem512 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM512 p+groupDecodePublicB MLKEM768 bs = case ML.decode mlkem768 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM768 p+groupDecodePublicB MLKEM1024 bs = case ML.decode mlkem1024 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM1024 p+groupDecodePublicB X25519MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 1088 bs+ in case ML.decode mlkem768 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_X25519MLKEM768 (p2, p1)+groupDecodePublicB P256MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 65 bs+ in case ML.decode mlkem768 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_P256MLKEM768 (p2, p1)+groupDecodePublicB P384MLKEM1024 bs =+ let (bs1, bs2) = BA.splitAt 97 bs+ in case ML.decode mlkem1024 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_P384MLKEM1024 (p2, p1)+groupDecodePublicB _ _ = error "groupDecodePublicB"+ -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.-valid :: Params -> PublicNumber -> Bool-valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1+valid :: DH.Params -> PublicNumber -> Bool+valid (DH.Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 -- strips leading zeros from the result of getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.-stripLeadingZeros :: SharedKey -> B.ScrubbedBytes-stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb+stripLeadingZeros :: DH.SharedKey -> ScrubbedBytes+stripLeadingZeros (DH.SharedKey sb) = snd $ BA.span (== 0) sb -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber
Network/TLS/Crypto/Types.hs view
@@ -19,11 +19,19 @@ FFDHE3072, FFDHE4096, FFDHE6144,- FFDHE8192+ FFDHE8192,+ MLKEM512,+ MLKEM768,+ MLKEM1024,+ X25519MLKEM768,+ P256MLKEM768,+ P384MLKEM1024 ), availableFFGroups, availableECGroups,+ availableHybridGroups, supportedNamedGroups,+ supportedNamedGroupsTLS13, KeyExchangeSignatureAlg (..), ) where @@ -55,6 +63,18 @@ pattern FFDHE6144 = Group 259 pattern FFDHE8192 :: Group pattern FFDHE8192 = Group 260+pattern MLKEM512 :: Group+pattern MLKEM512 = Group 512+pattern MLKEM768 :: Group+pattern MLKEM768 = Group 513+pattern MLKEM1024 :: Group+pattern MLKEM1024 = Group 514+pattern X25519MLKEM768 :: Group+pattern X25519MLKEM768 = Group 4588+pattern P256MLKEM768 :: Group+pattern P256MLKEM768 = Group 4587+pattern P384MLKEM1024 :: Group+pattern P384MLKEM1024 = Group 4589 instance Show Group where show P256 = "P256"@@ -67,6 +87,12 @@ show FFDHE4096 = "FFDHE4096" show FFDHE6144 = "FFDHE6144" show FFDHE8192 = "FFDHE8192"+ show MLKEM512 = "MLKEM512"+ show MLKEM768 = "MLKEM768"+ show MLKEM1024 = "MLKEM1024"+ show X25519MLKEM768 = "X25519MLKEM768"+ show P256MLKEM768 = "P256MLKEM768"+ show P384MLKEM1024 = "P384MLKEM1024" show (Group x) = "Group " ++ show x {- FOURMOLU_ENABLE -} @@ -76,8 +102,40 @@ availableECGroups :: [Group] availableECGroups = [P256, P384, P521, X25519, X448] +availableHybridGroups :: [Group]+availableHybridGroups = [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]++-- | A list for named groups. The ordering is for client preference+-- because server preference is not used in our server+-- implementation. supportedNamedGroups :: [Group]-supportedNamedGroups = [X25519, X448, P256, FFDHE3072, FFDHE4096, P384, FFDHE6144, FFDHE8192, P521]+supportedNamedGroups =+ [ X25519 -- 128 bits security+ , P256 -- 128 bits security+ , P384 -- 192 bits security+ , X448 -- 224 bits security+ , P521 -- 256 bits security+ -- , FFDHE2048 -- 103 bits security+ , FFDHE3072 -- 125 bits security+ , FFDHE4096 -- 150 bits security+ , FFDHE6144 -- 175 bits security+ , FFDHE8192 -- 192 bits security+ , X25519MLKEM768+ , P256MLKEM768+ , P384MLKEM1024+ , -- , MLKEM512+ MLKEM768+ , MLKEM1024+ ]++supportedNamedGroupsTLS13 :: [[Group]]+supportedNamedGroupsTLS13 =+ [ [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]+ , [X25519, P256]+ , [P384, X448, P521]+ , [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192]+ , [MLKEM768, MLKEM1024]+ ] -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3).
+ Network/TLS/Error.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}++module Network.TLS.Error where++import qualified Control.Exception as E++import Network.TLS.Imports++----------------------------------------------------------------++-- | TLSError that might be returned through the TLS stack.+--+-- Prior to version 1.8.0, this type had an @Exception@ instance.+-- In version 1.8.0, this instance was removed, and functions in+-- this library now only throw 'TLSException'.+data TLSError+ = -- | mainly for instance of Error+ Error_Misc String+ | -- | A fatal error condition was encountered at a low level. The+ -- elements of the tuple give (freeform text description, structured+ -- error description).+ Error_Protocol String AlertDescription+ | -- | A non-fatal error condition was encountered at a low level at a low+ -- level. The elements of the tuple give (freeform text description,+ -- structured error description).+ Error_Protocol_Warning String AlertDescription+ | Error_Certificate String+ | -- | handshake policy failed.+ Error_HandshakePolicy String+ | Error_EOF+ | Error_Packet String+ | Error_Packet_unexpected String String+ | Error_Packet_Parsing String+ | Error_TCP_Terminate+ deriving (Eq, Show)++----------------------------------------------------------------++-- | TLS Exceptions. Some of the data constructors indicate incorrect use of+-- the library, and the documentation for those data constructors calls+-- this out. The others wrap 'TLSError' with some kind of context to explain+-- when the exception occurred.+data TLSException+ = -- | Early termination exception with the reason and the error associated+ Terminated Bool String TLSError+ | -- | Handshake failed for the reason attached.+ HandshakeFailed TLSError+ | -- | Failure occurred while sending or receiving data after the+ -- TLS handshake succeeded.+ PostHandshake TLSError+ | -- | Lifts a 'TLSError' into 'TLSException' without provided any context+ -- around when the error happened.+ Uncontextualized TLSError+ | -- | Usage error when the connection has not been established+ -- and the user is trying to send or receive data.+ -- Indicates that this library has been used incorrectly.+ ConnectionNotEstablished+ | -- | Expected that a TLS handshake had already taken place, but no TLS+ -- handshake had occurred.+ -- Indicates that this library has been used incorrectly.+ MissingHandshake+ deriving (Show, Eq)++instance E.Exception TLSException++----------------------------------------------------------------++newtype AlertLevel = AlertLevel {fromAlertLevel :: Word8} deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern AlertLevel_Warning :: AlertLevel+pattern AlertLevel_Warning = AlertLevel 1+pattern AlertLevel_Fatal :: AlertLevel+pattern AlertLevel_Fatal = AlertLevel 2++instance Show AlertLevel where+ show AlertLevel_Warning = "AlertLevel_Warning"+ show AlertLevel_Fatal = "AlertLevel_Fatal"+ show (AlertLevel x) = "AlertLevel " ++ show x+{- FOURMOLU_ENABLE -}++----------------------------------------------------------------++newtype AlertDescription = AlertDescription {fromAlertDescription :: Word8}+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern CloseNotify :: AlertDescription+pattern CloseNotify = AlertDescription 0+pattern UnexpectedMessage :: AlertDescription+pattern UnexpectedMessage = AlertDescription 10+pattern BadRecordMac :: AlertDescription+pattern BadRecordMac = AlertDescription 20+pattern DecryptionFailed :: AlertDescription+pattern DecryptionFailed = AlertDescription 21+pattern RecordOverflow :: AlertDescription+pattern RecordOverflow = AlertDescription 22+pattern DecompressionFailure :: AlertDescription+pattern DecompressionFailure = AlertDescription 30+pattern HandshakeFailure :: AlertDescription+pattern HandshakeFailure = AlertDescription 40+pattern BadCertificate :: AlertDescription+pattern BadCertificate = AlertDescription 42+pattern UnsupportedCertificate :: AlertDescription+pattern UnsupportedCertificate = AlertDescription 43+pattern CertificateRevoked :: AlertDescription+pattern CertificateRevoked = AlertDescription 44+pattern CertificateExpired :: AlertDescription+pattern CertificateExpired = AlertDescription 45+pattern CertificateUnknown :: AlertDescription+pattern CertificateUnknown = AlertDescription 46+pattern IllegalParameter :: AlertDescription+pattern IllegalParameter = AlertDescription 47+pattern UnknownCa :: AlertDescription+pattern UnknownCa = AlertDescription 48+pattern AccessDenied :: AlertDescription+pattern AccessDenied = AlertDescription 49+pattern DecodeError :: AlertDescription+pattern DecodeError = AlertDescription 50+pattern DecryptError :: AlertDescription+pattern DecryptError = AlertDescription 51+pattern ExportRestriction :: AlertDescription+pattern ExportRestriction = AlertDescription 60+pattern ProtocolVersion :: AlertDescription+pattern ProtocolVersion = AlertDescription 70+pattern InsufficientSecurity :: AlertDescription+pattern InsufficientSecurity = AlertDescription 71+pattern InternalError :: AlertDescription+pattern InternalError = AlertDescription 80+pattern InappropriateFallback :: AlertDescription+pattern InappropriateFallback = AlertDescription 86 -- RFC7507+pattern UserCanceled :: AlertDescription+pattern UserCanceled = AlertDescription 90+pattern NoRenegotiation :: AlertDescription+pattern NoRenegotiation = AlertDescription 100+pattern MissingExtension :: AlertDescription+pattern MissingExtension = AlertDescription 109+pattern UnsupportedExtension :: AlertDescription+pattern UnsupportedExtension = AlertDescription 110+pattern CertificateUnobtainable :: AlertDescription+pattern CertificateUnobtainable = AlertDescription 111+pattern UnrecognizedName :: AlertDescription+pattern UnrecognizedName = AlertDescription 112+pattern BadCertificateStatusResponse :: AlertDescription+pattern BadCertificateStatusResponse = AlertDescription 113+pattern BadCertificateHashValue :: AlertDescription+pattern BadCertificateHashValue = AlertDescription 114+pattern UnknownPskIdentity :: AlertDescription+pattern UnknownPskIdentity = AlertDescription 115+pattern CertificateRequired :: AlertDescription+pattern CertificateRequired = AlertDescription 116+pattern GeneralError :: AlertDescription+pattern GeneralError = AlertDescription 117+pattern NoApplicationProtocol :: AlertDescription+pattern NoApplicationProtocol = AlertDescription 120 -- RFC7301+pattern EchRequired :: AlertDescription+pattern EchRequired = AlertDescription 121 -- draft++instance Show AlertDescription where+ show CloseNotify = "CloseNotify"+ show UnexpectedMessage = "UnexpectedMessage"+ show BadRecordMac = "BadRecordMac"+ show DecryptionFailed = "DecryptionFailed"+ show RecordOverflow = "RecordOverflow"+ show DecompressionFailure = "DecompressionFailure"+ show HandshakeFailure = "HandshakeFailure"+ show BadCertificate = "BadCertificate"+ show UnsupportedCertificate = "UnsupportedCertificate"+ show CertificateRevoked = "CertificateRevoked"+ show CertificateExpired = "CertificateExpired"+ show CertificateUnknown = "CertificateUnknown"+ show IllegalParameter = "IllegalParameter"+ show UnknownCa = "UnknownCa"+ show AccessDenied = "AccessDenied"+ show DecodeError = "DecodeError"+ show DecryptError = "DecryptError"+ show ExportRestriction = "ExportRestriction"+ show ProtocolVersion = "ProtocolVersion"+ show InsufficientSecurity = "InsufficientSecurity"+ show InternalError = "InternalError"+ show InappropriateFallback = "InappropriateFallback"+ show UserCanceled = "UserCanceled"+ show NoRenegotiation = "NoRenegotiation"+ show MissingExtension = "MissingExtension"+ show UnsupportedExtension = "UnsupportedExtension"+ show CertificateUnobtainable = "CertificateUnobtainable"+ show UnrecognizedName = "UnrecognizedName"+ show BadCertificateStatusResponse = "BadCertificateStatusResponse"+ show BadCertificateHashValue = "BadCertificateHashValue"+ show UnknownPskIdentity = "UnknownPskIdentity"+ show CertificateRequired = "CertificateRequired"+ show GeneralError = "GeneralError"+ show NoApplicationProtocol = "NoApplicationProtocol"+ show EchRequired = "EchRequired"+ show (AlertDescription x) = "AlertDescription " ++ show x+{- FOURMOLU_ENABLE -}
Network/TLS/Extension.hs view
@@ -1,627 +1,1211 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}---- | Basic extensions are defined in RFC 6066-module Network.TLS.Extension (- Extension (..),- supportedExtensions,- definedExtensions,- -- all implemented extensions- ServerNameType (..),- ServerName (..),- MaxFragmentLength (..),- MaxFragmentEnum (..),- SecureRenegotiation (..),- ApplicationLayerProtocolNegotiation (..),- ExtendedMainSecret (..),- SupportedGroups (..),- Group (..),- EcPointFormatsSupported (..),- EcPointFormat (- EcPointFormat,- EcPointFormat_Uncompressed,- EcPointFormat_AnsiX962_compressed_prime,- EcPointFormat_AnsiX962_compressed_char2- ),- SessionTicket (..),- HeartBeat (..),- HeartBeatMode (- HeartBeatMode,- HeartBeat_PeerAllowedToSend,- HeartBeat_PeerNotAllowedToSend- ),- SignatureAlgorithms (..),- SignatureAlgorithmsCert (..),- SupportedVersions (..),- KeyShare (..),- KeyShareEntry (..),- MessageType (..),- PostHandshakeAuth (..),- PskKexMode (PskKexMode, PSK_KE, PSK_DHE_KE),- PskKeyExchangeModes (..),- PskIdentity (..),- PreSharedKey (..),- EarlyDataIndication (..),- Cookie (..),- CertificateAuthorities (..),-) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC--import Network.TLS.Crypto.Types-import Network.TLS.Struct-import Network.TLS.Types (HostName, Ticket)--import Network.TLS.Imports-import Network.TLS.Packet (- getBinaryVersion,- getDNames,- getSignatureHashAlgorithm,- putBinaryVersion,- putDNames,- putSignatureHashAlgorithm,- )-import Network.TLS.Wire----------------------------------------------------------------definedExtensions :: [ExtensionID]-definedExtensions =- [ EID_ServerName- , EID_MaxFragmentLength- , EID_ClientCertificateUrl- , EID_TrustedCAKeys- , EID_TruncatedHMAC- , EID_StatusRequest- , EID_UserMapping- , EID_ClientAuthz- , EID_ServerAuthz- , EID_CertType- , EID_SupportedGroups- , EID_EcPointFormats- , EID_SRP- , EID_SignatureAlgorithms- , EID_SRTP- , EID_Heartbeat- , EID_ApplicationLayerProtocolNegotiation- , EID_StatusRequestv2- , EID_SignedCertificateTimestamp- , EID_ClientCertificateType- , EID_ServerCertificateType- , EID_Padding- , EID_EncryptThenMAC- , EID_ExtendedMainSecret- , EID_SessionTicket- , EID_PreSharedKey- , EID_EarlyData- , EID_SupportedVersions- , EID_Cookie- , EID_PskKeyExchangeModes- , EID_KeyShare- , EID_SignatureAlgorithmsCert- , EID_CertificateAuthorities- , EID_SecureRenegotiation- , EID_QuicTransportParameters- ]---- | all supported extensions by the implementation-supportedExtensions :: [ExtensionID]-supportedExtensions =- [ EID_ServerName- , EID_MaxFragmentLength- , EID_ApplicationLayerProtocolNegotiation- , EID_ExtendedMainSecret- , EID_SecureRenegotiation- , EID_SupportedGroups- , EID_EcPointFormats- , EID_SignatureAlgorithms- , EID_SignatureAlgorithmsCert- , EID_KeyShare- , EID_PreSharedKey- , EID_EarlyData- , EID_SupportedVersions- , EID_Cookie- , EID_PskKeyExchangeModes- , EID_CertificateAuthorities- , EID_QuicTransportParameters- ]----------------------------------------------------------------data MessageType- = MsgTClientHello- | MsgTServerHello- | MsgTHelloRetryRequest- | MsgTEncryptedExtensions- | MsgTNewSessionTicket- | MsgTCertificateRequest- deriving (Eq, Show)---- | Extension class to transform bytes to and from a high level Extension type.-class Extension a where- extensionID :: a -> ExtensionID- extensionDecode :: MessageType -> ByteString -> Maybe a- extensionEncode :: a -> ByteString------------------------------------------------------------------ | Server Name extension including the name type and the associated name.--- the associated name decoding is dependant of its name type.--- name type = 0 : hostname-newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq)--data ServerNameType- = ServerNameHostName HostName- | ServerNameOther (Word8, ByteString)- deriving (Show, Eq)--instance Extension ServerName where- extensionID _ = EID_ServerName- extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l)- 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 MsgTServerHello = decodeServerName- extensionDecode MsgTEncryptedExtensions = decodeServerName- extensionDecode _ = error "extensionDecode: ServerName"--decodeServerName :: ByteString -> Maybe ServerName-decodeServerName = runGetMaybe $ do- len <- fromIntegral <$> getWord16- ServerName <$> getList len getServerName- where- getServerName = do- ty <- getWord8- snameParsed <- getOpaque16- let sname = B.copy snameParsed- name = case ty of- 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion- _ -> ServerNameOther (ty, sname)- return (1 + 2 + B.length sname, name)------------------------------------------------------------------ | Max fragment extension with length from 512 bytes to 4096 bytes------ RFC 6066 defines:--- If a server receives a maximum fragment length negotiation request--- for a value other than the allowed values, it MUST abort the--- handshake with an "illegal_parameter" alert.------ So, if a server receives MaxFragmentLengthOther, it must send the alert.-data MaxFragmentLength- = MaxFragmentLength MaxFragmentEnum- | MaxFragmentLengthOther Word8- deriving (Show, Eq)--data MaxFragmentEnum- = MaxFragment512- | MaxFragment1024- | MaxFragment2048- | MaxFragment4096- deriving (Show, Eq)--instance Extension MaxFragmentLength where- extensionID _ = EID_MaxFragmentLength- extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l- where- fromMaxFragmentEnum MaxFragment512 = 1- fromMaxFragmentEnum MaxFragment1024 = 2- fromMaxFragmentEnum MaxFragment2048 = 3- fromMaxFragmentEnum MaxFragment4096 = 4- extensionEncode (MaxFragmentLengthOther l) = runPut $ putWord8 l- extensionDecode MsgTClientHello = decodeMaxFragmentLength- extensionDecode MsgTServerHello = decodeMaxFragmentLength- extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength- extensionDecode _ = error "extensionDecode: MaxFragmentLength"--decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength-decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8- where- toMaxFragmentEnum 1 = MaxFragmentLength MaxFragment512- toMaxFragmentEnum 2 = MaxFragmentLength MaxFragment1024- toMaxFragmentEnum 3 = MaxFragmentLength MaxFragment2048- toMaxFragmentEnum 4 = MaxFragmentLength MaxFragment4096- toMaxFragmentEnum n = MaxFragmentLengthOther n------------------------------------------------------------------ | Secure Renegotiation-data SecureRenegotiation = SecureRenegotiation ByteString ByteString- deriving (Show, Eq)--instance Extension SecureRenegotiation where- extensionID _ = EID_SecureRenegotiation- extensionEncode (SecureRenegotiation cvd svd) =- runPut $ putOpaque8 (cvd `B.append` svd)- extensionDecode msgtype = runGetMaybe $ do- opaque <- getOpaque8- case msgtype of- MsgTServerHello ->- let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque- in return $ SecureRenegotiation cvd svd- MsgTClientHello -> return $ SecureRenegotiation opaque ""- _ -> error "extensionDecode: SecureRenegotiation"------------------------------------------------------------------ | Application Layer Protocol Negotiation (ALPN)-newtype ApplicationLayerProtocolNegotiation- = ApplicationLayerProtocolNegotiation [ByteString]- deriving (Show, Eq)--instance Extension ApplicationLayerProtocolNegotiation where- extensionID _ = EID_ApplicationLayerProtocolNegotiation- extensionEncode (ApplicationLayerProtocolNegotiation bytes) =- runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes- extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation- extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation- extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation- extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation"--decodeApplicationLayerProtocolNegotiation- :: ByteString -> Maybe ApplicationLayerProtocolNegotiation-decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do- len <- getWord16- ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN- where- getALPN = do- alpnParsed <- getOpaque8- let alpn = B.copy alpnParsed- return (B.length alpn + 1, alpn)------------------------------------------------------------------ | Extended Main Secret-data ExtendedMainSecret = ExtendedMainSecret deriving (Show, Eq)--instance Extension ExtendedMainSecret where- extensionID _ = EID_ExtendedMainSecret- extensionEncode ExtendedMainSecret = B.empty- extensionDecode MsgTClientHello _ = Just ExtendedMainSecret- extensionDecode MsgTServerHello _ = Just ExtendedMainSecret- extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret"----------------------------------------------------------------newtype SupportedGroups = SupportedGroups [Group] deriving (Show, Eq)---- on decode, filter all unknown curves-instance Extension SupportedGroups where- extensionID _ = EID_SupportedGroups- extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups- extensionDecode MsgTClientHello = decodeSupportedGroups- extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups- extensionDecode _ = error "extensionDecode: SupportedGroups"--decodeSupportedGroups :: ByteString -> Maybe SupportedGroups-decodeSupportedGroups =- runGetMaybe (SupportedGroups . map Group <$> getWords16)----------------------------------------------------------------newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat]- deriving (Show, Eq)--newtype EcPointFormat = EcPointFormat {fromEcPointFormat :: Word8}- deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern EcPointFormat_Uncompressed :: EcPointFormat-pattern EcPointFormat_Uncompressed = EcPointFormat 0-pattern EcPointFormat_AnsiX962_compressed_prime :: EcPointFormat-pattern EcPointFormat_AnsiX962_compressed_prime = EcPointFormat 1-pattern EcPointFormat_AnsiX962_compressed_char2 :: EcPointFormat-pattern EcPointFormat_AnsiX962_compressed_char2 = EcPointFormat 2--instance Show EcPointFormat where- show EcPointFormat_Uncompressed = "EcPointFormat_Uncompressed"- show EcPointFormat_AnsiX962_compressed_prime = "EcPointFormat_AnsiX962_compressed_prime"- show EcPointFormat_AnsiX962_compressed_char2 = "EcPointFormat_AnsiX962_compressed_char2"- show (EcPointFormat x) = "EcPointFormat " ++ show x-{- FOURMOLU_ENABLE -}---- on decode, filter all unknown formats-instance Extension EcPointFormatsSupported where- extensionID _ = EID_EcPointFormats- extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats- extensionDecode MsgTClientHello = decodeEcPointFormatsSupported- extensionDecode MsgTServerHello = decodeEcPointFormatsSupported- extensionDecode _ = error "extensionDecode: EcPointFormatsSupported"--decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported-decodeEcPointFormatsSupported =- runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8)----------------------------------------------------------------newtype SessionTicket = SessionTicket Ticket- deriving (Show, Eq)---- https://datatracker.ietf.org/doc/html/rfc5077#appendix-A-instance Extension SessionTicket where- extensionID _ = EID_SessionTicket- extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket- extensionDecode MsgTClientHello = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)- extensionDecode MsgTServerHello = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)- extensionDecode _ = error "extensionDecode: SessionTicket"----------------------------------------------------------------newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq)--newtype HeartBeatMode = HeartBeatMode {fromHeartBeatMode :: Word8}- deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern HeartBeat_PeerAllowedToSend :: HeartBeatMode-pattern HeartBeat_PeerAllowedToSend = HeartBeatMode 1-pattern HeartBeat_PeerNotAllowedToSend :: HeartBeatMode-pattern HeartBeat_PeerNotAllowedToSend = HeartBeatMode 2--instance Show HeartBeatMode where- show HeartBeat_PeerAllowedToSend = "HeartBeat_PeerAllowedToSend"- show HeartBeat_PeerNotAllowedToSend = "HeartBeat_PeerNotAllowedToSend"- show (HeartBeatMode x) = "HeartBeatMode " ++ show x-{- FOURMOLU_ENABLE -}--instance Extension HeartBeat where- extensionID _ = EID_Heartbeat- extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode- extensionDecode MsgTClientHello = decodeHeartBeat- extensionDecode MsgTServerHello = decodeHeartBeat- extensionDecode _ = error "extensionDecode: HeartBeat"--decodeHeartBeat :: ByteString -> Maybe HeartBeat-decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8----------------------------------------------------------------newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm]- deriving (Show, Eq)--instance Extension SignatureAlgorithms where- extensionID _ = EID_SignatureAlgorithms- extensionEncode (SignatureAlgorithms algs) =- runPut $- putWord16 (fromIntegral (length algs * 2))- >> mapM_ putSignatureHashAlgorithm algs- extensionDecode MsgTClientHello = decodeSignatureAlgorithms- extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms- extensionDecode _ = error "extensionDecode: SignatureAlgorithms"--decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms-decodeSignatureAlgorithms = runGetMaybe $ do- len <- getWord16- sas <-- getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))- leftoverLen <- remaining- when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length"- return $ SignatureAlgorithms sas----------------------------------------------------------------data PostHandshakeAuth = PostHandshakeAuth deriving (Show, Eq)--instance Extension PostHandshakeAuth where- extensionID _ = EID_PostHandshakeAuth- extensionEncode _ = B.empty- extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth- extensionDecode _ = error "extensionDecode: PostHandshakeAuth"----------------------------------------------------------------newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm]- deriving (Show, Eq)--instance Extension SignatureAlgorithmsCert where- extensionID _ = EID_SignatureAlgorithmsCert- extensionEncode (SignatureAlgorithmsCert algs) =- runPut $- putWord16 (fromIntegral (length algs * 2))- >> mapM_ putSignatureHashAlgorithm algs- extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert- extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert- extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert"--decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert-decodeSignatureAlgorithmsCert = runGetMaybe $ do- len <- getWord16- SignatureAlgorithmsCert- <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))----------------------------------------------------------------data SupportedVersions- = SupportedVersionsClientHello [Version]- | SupportedVersionsServerHello Version- deriving (Show, Eq)--instance Extension SupportedVersions where- extensionID _ = EID_SupportedVersions- extensionEncode (SupportedVersionsClientHello vers) = runPut $ do- putWord8 (fromIntegral (length vers * 2))- mapM_ putBinaryVersion vers- extensionEncode (SupportedVersionsServerHello ver) =- runPut $- putBinaryVersion ver- extensionDecode MsgTClientHello = runGetMaybe $ do- len <- fromIntegral <$> getWord8- SupportedVersionsClientHello <$> getList len getVer- where- getVer = do- ver <- getBinaryVersion- return (2, ver)- extensionDecode MsgTServerHello =- runGetMaybe (SupportedVersionsServerHello <$> getBinaryVersion)- extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello"----------------------------------------------------------------data KeyShareEntry = KeyShareEntry- { keyShareEntryGroup :: Group- , keyShareEntryKeyExchange :: ByteString- }- deriving (Show, Eq)--getKeyShareEntry :: Get (Int, Maybe KeyShareEntry)-getKeyShareEntry = do- grp <- Group <$> getWord16- l <- fromIntegral <$> getWord16- key <- getBytes l- let len = l + 4- return (len, Just $ KeyShareEntry grp key)--putKeyShareEntry :: KeyShareEntry -> Put-putKeyShareEntry (KeyShareEntry (Group grp) key) = do- putWord16 grp- putWord16 $ fromIntegral $ B.length key- putBytes key--data KeyShare- = KeyShareClientHello [KeyShareEntry]- | KeyShareServerHello KeyShareEntry- | KeyShareHRR Group- deriving (Show, Eq)--instance Extension KeyShare where- extensionID _ = EID_KeyShare- extensionEncode (KeyShareClientHello kses) = runPut $ do- let len = sum [B.length key + 4 | KeyShareEntry _ key <- kses]- putWord16 $ fromIntegral len- mapM_ putKeyShareEntry kses- extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse- extensionEncode (KeyShareHRR (Group grp)) = runPut $ putWord16 grp- extensionDecode MsgTServerHello = runGetMaybe $ do- (_, ment) <- getKeyShareEntry- case ment of- Nothing -> fail "decoding KeyShare for ServerHello"- Just ent -> return $ KeyShareServerHello ent- extensionDecode MsgTClientHello = runGetMaybe $ do- len <- fromIntegral <$> getWord16- -- len == 0 allows for HRR- grps <- getList len getKeyShareEntry- return $ KeyShareClientHello $ catMaybes grps- extensionDecode MsgTHelloRetryRequest =- runGetMaybe $- KeyShareHRR . Group <$> getWord16- extensionDecode _ = error "extensionDecode: KeyShare"----------------------------------------------------------------newtype PskKexMode = PskKexMode {fromPskKexMode :: Word8} deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern PSK_KE :: PskKexMode-pattern PSK_KE = PskKexMode 0-pattern PSK_DHE_KE :: PskKexMode-pattern PSK_DHE_KE = PskKexMode 1--instance Show PskKexMode where- show PSK_KE = "PSK_KE"- show PSK_DHE_KE = "PSK_DHE_KE"- show (PskKexMode x) = "PskKexMode " ++ show x-{- FOURMOLU_ENABLE -}--newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode]- deriving (Eq, Show)--instance Extension PskKeyExchangeModes where- extensionID _ = EID_PskKeyExchangeModes- extensionEncode (PskKeyExchangeModes pkms) =- runPut $- putWords8 $- map fromPskKexMode pkms- extensionDecode MsgTClientHello =- runGetMaybe $- PskKeyExchangeModes . map PskKexMode <$> getWords8- extensionDecode _ = error "extensionDecode: PskKeyExchangeModes"----------------------------------------------------------------data PskIdentity = PskIdentity ByteString Word32 deriving (Eq, Show)--data PreSharedKey- = PreSharedKeyClientHello [PskIdentity] [ByteString]- | PreSharedKeyServerHello Int- deriving (Eq, Show)--instance Extension PreSharedKey where- extensionID _ = EID_PreSharedKey- extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do- putOpaque16 $ runPut (mapM_ putIdentity ids)- putOpaque16 $ runPut (mapM_ putBinder bds)- where- putIdentity (PskIdentity bs w) = do- putOpaque16 bs- putWord32 w- putBinder = putOpaque8- extensionEncode (PreSharedKeyServerHello w16) =- runPut $- putWord16 $- fromIntegral w16- extensionDecode MsgTServerHello =- runGetMaybe $- PreSharedKeyServerHello . fromIntegral <$> getWord16- extensionDecode MsgTClientHello = runGetMaybe $ do- len1 <- fromIntegral <$> getWord16- identities <- getList len1 getIdentity- len2 <- fromIntegral <$> getWord16- binders <- getList len2 getBinder- return $ PreSharedKeyClientHello identities binders- where- getIdentity = do- identity <- getOpaque16- age <- getWord32- let len = 2 + B.length identity + 4- return (len, PskIdentity identity age)- getBinder = do- l <- fromIntegral <$> getWord8- binder <- getBytes l- let len = l + 1- return (len, binder)- extensionDecode _ = error "extensionDecode: PreShareKey"----------------------------------------------------------------newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32)- deriving (Eq, Show)--instance Extension EarlyDataIndication where- 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"----------------------------------------------------------------newtype Cookie = Cookie ByteString deriving (Eq, Show)--instance Extension Cookie where- extensionID _ = EID_Cookie- extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque- extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)- extensionDecode _ = error "extensionDecode: Cookie"----------------------------------------------------------------newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName]- deriving (Eq, Show)--instance Extension CertificateAuthorities where- extensionID _ = EID_CertificateAuthorities- extensionEncode (CertificateAuthorities names) =- runPut $- putDNames names- extensionDecode MsgTClientHello =- runGetMaybe (CertificateAuthorities <$> getDNames)- extensionDecode MsgTCertificateRequest =- runGetMaybe (CertificateAuthorities <$> getDNames)- extensionDecode _ = error "extensionDecode: CertificateAuthorities"+{-# LANGUAGE RecordWildCards #-}++-- | Basic extensions are defined in RFC 6066+module Network.TLS.Extension (+ -- * Extension identifiers+ ExtensionID (+ ..,+ EID_ServerName,+ EID_MaxFragmentLength,+ EID_ClientCertificateUrl,+ EID_TrustedCAKeys,+ EID_TruncatedHMAC,+ EID_StatusRequest,+ EID_UserMapping,+ EID_ClientAuthz,+ EID_ServerAuthz,+ EID_CertType,+ EID_SupportedGroups,+ EID_EcPointFormats,+ EID_SRP,+ EID_SignatureAlgorithms,+ EID_SRTP,+ EID_Heartbeat,+ EID_ApplicationLayerProtocolNegotiation,+ EID_StatusRequestv2,+ EID_SignedCertificateTimestamp,+ EID_ClientCertificateType,+ EID_ServerCertificateType,+ EID_Padding,+ EID_EncryptThenMAC,+ EID_ExtendedMainSecret,+ EID_CompressCertificate,+ EID_RecordSizeLimit,+ EID_SessionTicket,+ EID_PreSharedKey,+ EID_EarlyData,+ EID_SupportedVersions,+ EID_Cookie,+ EID_PskKeyExchangeModes,+ EID_CertificateAuthorities,+ EID_OidFilters,+ EID_PostHandshakeAuth,+ EID_SignatureAlgorithmsCert,+ EID_KeyShare,+ EID_QuicTransportParameters,+ EID_EchOuterExtensions,+ EID_EncryptedClientHello,+ EID_SecureRenegotiation+ ),+ definedExtensions,+ supportedExtensions,++ -- * Extension raw+ ExtensionRaw (..),+ toExtensionRaw,+ extensionLookup,+ lookupAndDecode,+ lookupAndDecodeAndDo,++ -- * Class+ Extension (..),++ -- * Extensions+ ServerNameType (..),+ ServerName (..),+ MaxFragmentLength (..),+ MaxFragmentEnum (..),+ SecureRenegotiation (..),+ ApplicationLayerProtocolNegotiation (..),+ ExtendedMainSecret (..),+ CertificateCompressionAlgorithm (.., CCA_Zlib, CCA_Brotli, CCA_Zstd),+ CompressCertificate (..),+ SupportedGroups (..),+ Group (..),+ EcPointFormatsSupported (..),+ EcPointFormat (+ EcPointFormat,+ EcPointFormat_Uncompressed,+ EcPointFormat_AnsiX962_compressed_prime,+ EcPointFormat_AnsiX962_compressed_char2+ ),+ RecordSizeLimit (..),+ SessionTicket (..),+ HeartBeat (..),+ HeartBeatMode (+ HeartBeatMode,+ HeartBeat_PeerAllowedToSend,+ HeartBeat_PeerNotAllowedToSend+ ),+ SignatureAlgorithms (..),+ SignatureAlgorithmsCert (..),+ SupportedVersions (..),+ KeyShare (..),+ KeyShareEntry (..),+ MessageType (..),+ PostHandshakeAuth (..),+ PskKexMode (PskKexMode, PSK_KE, PSK_DHE_KE),+ PskKeyExchangeModes (..),+ PskIdentity (..),+ PreSharedKey (..),+ EarlyDataIndication (..),+ Cookie (..),+ CertificateAuthorities (..),+ EchOuterExtensions (..),+ EncryptedClientHello (..),+) where++import qualified Control.Exception as E+import Crypto.HPKE+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.X509 (DistinguishedName)++import Network.TLS.ECH.Config++import Network.TLS.Crypto.Types+import Network.TLS.Error+import Network.TLS.HashAndSignature+import Network.TLS.Imports+import Network.TLS.Packet (+ getBinaryVersion,+ getDNames,+ getSignatureHashAlgorithm,+ putBinaryVersion,+ putDNames,+ putSignatureHashAlgorithm,+ )+import Network.TLS.Types (HostName, Ticket, Version)+import Network.TLS.Wire++----------------------------------------------------------------+-- Extension identifiers++-- | Identifier of a TLS extension.+-- <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt>+newtype ExtensionID = ExtensionID {fromExtensionID :: Word16} deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern EID_ServerName :: ExtensionID -- RFC6066+pattern EID_ServerName = ExtensionID 0x0+pattern EID_MaxFragmentLength :: ExtensionID -- RFC6066+pattern EID_MaxFragmentLength = ExtensionID 0x1+pattern EID_ClientCertificateUrl :: ExtensionID -- RFC6066+pattern EID_ClientCertificateUrl = ExtensionID 0x2+pattern EID_TrustedCAKeys :: ExtensionID -- RFC6066+pattern EID_TrustedCAKeys = ExtensionID 0x3+pattern EID_TruncatedHMAC :: ExtensionID -- RFC6066+pattern EID_TruncatedHMAC = ExtensionID 0x4+pattern EID_StatusRequest :: ExtensionID -- RFC6066+pattern EID_StatusRequest = ExtensionID 0x5+pattern EID_UserMapping :: ExtensionID -- RFC4681+pattern EID_UserMapping = ExtensionID 0x6+pattern EID_ClientAuthz :: ExtensionID -- RFC5878+pattern EID_ClientAuthz = ExtensionID 0x7+pattern EID_ServerAuthz :: ExtensionID -- RFC5878+pattern EID_ServerAuthz = ExtensionID 0x8+pattern EID_CertType :: ExtensionID -- RFC6091+pattern EID_CertType = ExtensionID 0x9+pattern EID_SupportedGroups :: ExtensionID -- RFC8422,8446+pattern EID_SupportedGroups = ExtensionID 0xa+pattern EID_EcPointFormats :: ExtensionID -- RFC4492+pattern EID_EcPointFormats = ExtensionID 0xb+pattern EID_SRP :: ExtensionID -- RFC5054+pattern EID_SRP = ExtensionID 0xc+pattern EID_SignatureAlgorithms :: ExtensionID -- RFC5246,8446+pattern EID_SignatureAlgorithms = ExtensionID 0xd+pattern EID_SRTP :: ExtensionID -- RFC5764+pattern EID_SRTP = ExtensionID 0xe+pattern EID_Heartbeat :: ExtensionID -- RFC6520+pattern EID_Heartbeat = ExtensionID 0xf+pattern EID_ApplicationLayerProtocolNegotiation :: ExtensionID -- RFC7301+pattern EID_ApplicationLayerProtocolNegotiation = ExtensionID 0x10+pattern EID_StatusRequestv2 :: ExtensionID -- RFC6961+pattern EID_StatusRequestv2 = ExtensionID 0x11+pattern EID_SignedCertificateTimestamp :: ExtensionID -- RFC6962+pattern EID_SignedCertificateTimestamp = ExtensionID 0x12+pattern EID_ClientCertificateType :: ExtensionID -- RFC7250+pattern EID_ClientCertificateType = ExtensionID 0x13+pattern EID_ServerCertificateType :: ExtensionID -- RFC7250+pattern EID_ServerCertificateType = ExtensionID 0x14+pattern EID_Padding :: ExtensionID -- RFC5246+pattern EID_Padding = ExtensionID 0x15+pattern EID_EncryptThenMAC :: ExtensionID -- RFC7366+pattern EID_EncryptThenMAC = ExtensionID 0x16+pattern EID_ExtendedMainSecret :: ExtensionID -- REF7627+pattern EID_ExtendedMainSecret = ExtensionID 0x17+pattern EID_CompressCertificate :: ExtensionID -- RFC8879+pattern EID_CompressCertificate = ExtensionID 0x1b+pattern EID_RecordSizeLimit :: ExtensionID -- RFC8449+pattern EID_RecordSizeLimit = ExtensionID 0x1c+pattern EID_SessionTicket :: ExtensionID -- RFC4507+pattern EID_SessionTicket = ExtensionID 0x23+pattern EID_PreSharedKey :: ExtensionID -- RFC8446+pattern EID_PreSharedKey = ExtensionID 0x29+pattern EID_EarlyData :: ExtensionID -- RFC8446+pattern EID_EarlyData = ExtensionID 0x2a+pattern EID_SupportedVersions :: ExtensionID -- RFC8446+pattern EID_SupportedVersions = ExtensionID 0x2b+pattern EID_Cookie :: ExtensionID -- RFC8446+pattern EID_Cookie = ExtensionID 0x2c+pattern EID_PskKeyExchangeModes :: ExtensionID -- RFC8446+pattern EID_PskKeyExchangeModes = ExtensionID 0x2d+pattern EID_CertificateAuthorities :: ExtensionID -- RFC8446+pattern EID_CertificateAuthorities = ExtensionID 0x2f+pattern EID_OidFilters :: ExtensionID -- RFC8446+pattern EID_OidFilters = ExtensionID 0x30+pattern EID_PostHandshakeAuth :: ExtensionID -- RFC8446+pattern EID_PostHandshakeAuth = ExtensionID 0x31+pattern EID_SignatureAlgorithmsCert :: ExtensionID -- RFC8446+pattern EID_SignatureAlgorithmsCert = ExtensionID 0x32+pattern EID_KeyShare :: ExtensionID -- RFC8446+pattern EID_KeyShare = ExtensionID 0x33+pattern EID_QuicTransportParameters :: ExtensionID -- RFC9001+pattern EID_QuicTransportParameters = ExtensionID 0x39+pattern EID_EchOuterExtensions :: ExtensionID -- draft+pattern EID_EchOuterExtensions = ExtensionID 0xfd00+pattern EID_EncryptedClientHello :: ExtensionID -- draft+pattern EID_EncryptedClientHello = ExtensionID 0xfe0d+pattern EID_SecureRenegotiation :: ExtensionID -- RFC5746+pattern EID_SecureRenegotiation = ExtensionID 0xff01++instance Show ExtensionID where+ show EID_ServerName = "ServerName"+ show EID_MaxFragmentLength = "MaxFragmentLength"+ show EID_ClientCertificateUrl = "ClientCertificateUrl"+ show EID_TrustedCAKeys = "TrustedCAKeys"+ show EID_TruncatedHMAC = "TruncatedHMAC"+ show EID_StatusRequest = "StatusRequest"+ show EID_UserMapping = "UserMapping"+ show EID_ClientAuthz = "ClientAuthz"+ show EID_ServerAuthz = "ServerAuthz"+ show EID_CertType = "CertType"+ show EID_SupportedGroups = "SupportedGroups"+ show EID_EcPointFormats = "EcPointFormats"+ show EID_SRP = "SRP"+ show EID_SignatureAlgorithms = "SignatureAlgorithms"+ show EID_SRTP = "SRTP"+ show EID_Heartbeat = "Heartbeat"+ show EID_ApplicationLayerProtocolNegotiation = "ApplicationLayerProtocolNegotiation"+ show EID_StatusRequestv2 = "StatusRequestv2"+ show EID_SignedCertificateTimestamp = "SignedCertificateTimestamp"+ show EID_ClientCertificateType = "ClientCertificateType"+ show EID_ServerCertificateType = "ServerCertificateType"+ show EID_Padding = "Padding"+ show EID_EncryptThenMAC = "EncryptThenMAC"+ show EID_ExtendedMainSecret = "ExtendedMainSecret"+ show EID_CompressCertificate = "CompressCertificate"+ show EID_RecordSizeLimit = "RecordSizeLimit"+ show EID_SessionTicket = "SessionTicket"+ show EID_PreSharedKey = "PreSharedKey"+ show EID_EarlyData = "EarlyData"+ show EID_SupportedVersions = "SupportedVersions"+ show EID_Cookie = "Cookie"+ show EID_PskKeyExchangeModes = "PskKeyExchangeModes"+ show EID_CertificateAuthorities = "CertificateAuthorities"+ show EID_OidFilters = "OidFilters"+ show EID_PostHandshakeAuth = "PostHandshakeAuth"+ show EID_SignatureAlgorithmsCert = "SignatureAlgorithmsCert"+ show EID_KeyShare = "KeyShare"+ show EID_QuicTransportParameters = "QuicTransportParameters"+ show EID_EchOuterExtensions = "EchOuterExtensions"+ show EID_EncryptedClientHello = "EncryptedClientHello"+ show EID_SecureRenegotiation = "SecureRenegotiation"+ show (ExtensionID x) = "ExtensionID " ++ show x+{- FOURMOLU_ENABLE -}++------------------------------------------------------------++definedExtensions :: [ExtensionID]+definedExtensions =+ [ EID_ServerName+ , EID_MaxFragmentLength+ , EID_ClientCertificateUrl+ , EID_TrustedCAKeys+ , EID_TruncatedHMAC+ , EID_StatusRequest+ , EID_UserMapping+ , EID_ClientAuthz+ , EID_ServerAuthz+ , EID_CertType+ , EID_SupportedGroups+ , EID_EcPointFormats+ , EID_SRP+ , EID_SignatureAlgorithms+ , EID_SRTP+ , EID_Heartbeat+ , EID_ApplicationLayerProtocolNegotiation+ , EID_StatusRequestv2+ , EID_SignedCertificateTimestamp+ , EID_ClientCertificateType+ , EID_ServerCertificateType+ , EID_Padding+ , EID_EncryptThenMAC+ , EID_ExtendedMainSecret+ , EID_CompressCertificate+ , EID_RecordSizeLimit+ , EID_SessionTicket+ , EID_PreSharedKey+ , EID_EarlyData+ , EID_SupportedVersions+ , EID_Cookie+ , EID_PskKeyExchangeModes+ , EID_CertificateAuthorities+ , EID_OidFilters+ , EID_PostHandshakeAuth+ , EID_SignatureAlgorithmsCert+ , EID_KeyShare+ , EID_QuicTransportParameters+ , EID_EchOuterExtensions+ , EID_EncryptedClientHello+ , EID_SecureRenegotiation+ ]++-- | all supported extensions by the implementation+{- FOURMOLU_DISABLE -}+supportedExtensions :: [ExtensionID]+supportedExtensions =+ [ EID_ServerName -- 0x00+ , EID_SupportedGroups -- 0x0a+ , EID_EcPointFormats -- 0x0b+ , EID_SignatureAlgorithms -- 0x0d+ , EID_ApplicationLayerProtocolNegotiation -- 0x10+ , EID_ExtendedMainSecret -- 0x17+ , EID_CompressCertificate -- 0x1b+ , EID_RecordSizeLimit -- 0x1c+ , EID_SessionTicket -- 0x23+ , EID_PreSharedKey -- 0x29+ , EID_EarlyData -- 0x2a+ , EID_SupportedVersions -- 0x2b+ , EID_Cookie -- 0x2c+ , EID_PskKeyExchangeModes -- 0x2d+ , EID_CertificateAuthorities -- 0x2f+ , EID_PostHandshakeAuth -- 0x31+ , EID_SignatureAlgorithmsCert -- 0x32+ , EID_KeyShare -- 0x33+ , EID_QuicTransportParameters -- 0x39+ , EID_EchOuterExtensions -- 0xfd00+ , EID_EncryptedClientHello -- 0xfe0d+ , EID_SecureRenegotiation -- 0xff01+ ]+{- FOURMOLU_ENABLE -}++----------------------------------------------------------------++-- | The raw content of a TLS extension.+data ExtensionRaw = ExtensionRaw ExtensionID ByteString+ deriving (Eq)++instance Show ExtensionRaw where+ show (ExtensionRaw eid@EID_ServerName bs) = showExtensionRaw eid bs decodeServerName+ show (ExtensionRaw eid@EID_MaxFragmentLength bs) = showExtensionRaw eid bs decodeMaxFragmentLength+ show (ExtensionRaw eid@EID_SupportedGroups bs) = showExtensionRaw eid bs decodeSupportedGroups+ show (ExtensionRaw eid@EID_EcPointFormats bs) = showExtensionRaw eid bs decodeEcPointFormatsSupported+ show (ExtensionRaw eid@EID_SignatureAlgorithms bs) = showExtensionRaw eid bs decodeSignatureAlgorithms+ show (ExtensionRaw eid@EID_Heartbeat bs) = showExtensionRaw eid bs decodeHeartBeat+ show (ExtensionRaw eid@EID_ApplicationLayerProtocolNegotiation bs) = showExtensionRaw eid bs decodeApplicationLayerProtocolNegotiation+ show (ExtensionRaw eid@EID_ExtendedMainSecret _) = show eid+ show (ExtensionRaw eid@EID_CompressCertificate bs) = showExtensionRaw eid bs decodeCompressCertificate+ show (ExtensionRaw eid@EID_RecordSizeLimit bs) = showExtensionRaw eid bs decodeRecordSizeLimit+ show (ExtensionRaw eid@EID_SessionTicket bs) = showExtensionRaw eid bs decodeSessionTicket+ show (ExtensionRaw eid@EID_PreSharedKey bs) = showExtensionRaw eid bs decodePreSharedKey+ show (ExtensionRaw eid@EID_EarlyData _) = show eid+ show (ExtensionRaw eid@EID_SupportedVersions bs) = showExtensionRaw eid bs decodeSupportedVersions+ show (ExtensionRaw eid@EID_Cookie bs) = show eid ++ " " ++ showBytesHex bs+ show (ExtensionRaw eid@EID_PskKeyExchangeModes bs) = showExtensionRaw eid bs decodePskKeyExchangeModes+ show (ExtensionRaw eid@EID_CertificateAuthorities bs) = showExtensionRaw eid bs decodeCertificateAuthorities+ show (ExtensionRaw eid@EID_PostHandshakeAuth _) = show eid+ show (ExtensionRaw eid@EID_SignatureAlgorithmsCert bs) = showExtensionRaw eid bs decodeSignatureAlgorithmsCert+ show (ExtensionRaw eid@EID_KeyShare bs) = showExtensionRaw eid bs decodeKeyShare+ show (ExtensionRaw eid@EID_EchOuterExtensions bs) = showExtensionRaw eid bs decodeEchOuterExtensions+ show (ExtensionRaw eid@EID_EncryptedClientHello bs) = showExtensionRaw eid bs decodeECH+ show (ExtensionRaw eid@EID_SecureRenegotiation bs) = show eid ++ " " ++ showBytesHex bs+ show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs++showExtensionRaw+ :: Show a => ExtensionID -> ByteString -> (ByteString -> Maybe a) -> String+showExtensionRaw eid bs decode = case decode bs of+ Nothing -> show eid ++ " broken"+ Just x -> show x++toExtensionRaw :: Extension e => e -> ExtensionRaw+toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext)++extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString+extensionLookup toFind exts = extract <$> find idEq exts+ where+ extract (ExtensionRaw _ content) = content+ idEq (ExtensionRaw eid _) = eid == toFind++lookupAndDecode+ :: Extension e+ => ExtensionID+ -> MessageType+ -> [ExtensionRaw]+ -> a+ -> (e -> a)+ -> a+lookupAndDecode eid msgtyp exts defval conv = case extensionLookup eid exts of+ Nothing -> defval+ Just bs -> case extensionDecode msgtyp bs of+ Nothing ->+ E.throw $+ Uncontextualized $+ Error_Protocol ("Illegal " ++ show eid) DecodeError+ Just val -> conv val++lookupAndDecodeAndDo+ :: Extension a+ => ExtensionID+ -> MessageType+ -> [ExtensionRaw]+ -> IO b+ -> (a -> IO b)+ -> IO b+lookupAndDecodeAndDo eid msgtyp exts defAction action = case extensionLookup eid exts of+ Nothing -> defAction+ Just bs -> case extensionDecode msgtyp bs of+ Nothing ->+ E.throwIO $+ Uncontextualized $+ Error_Protocol ("Illegal " ++ show eid) DecodeError+ Just val -> action val++------------------------------------------------------------++-- | 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+ = MsgTClientHello+ | MsgTServerHello+ | MsgTHelloRetryRequest+ | MsgTEncryptedExtensions+ | MsgTNewSessionTicket+ | MsgTCertificateRequest+ deriving (Eq, Show, Enum, Bounded)++------------------------------------------------------------++-- | Server Name extension including the name type and the associated name.+-- the associated name decoding is dependent of its name type.+-- name type = 0 : hostname+newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq)++data ServerNameType+ = ServerNameHostName HostName+ | ServerNameOther (Word8, ByteString)+ deriving (Eq)++instance Show ServerNameType where+ show (ServerNameHostName host) = "\"" ++ host ++ "\""+ show (ServerNameOther (w, _)) = "(" ++ show w ++ ", )"++instance Extension ServerName where+ extensionID _ = EID_ServerName++ -- dirty hack for servers+ extensionEncode (ServerName []) = ""+ -- for clients+ extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l)+ 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 = decodeServerNameList+ extensionDecode MsgTServerHello = decodeServerName+ extensionDecode MsgTEncryptedExtensions = decodeServerName+ extensionDecode _ = const Nothing++decodeServerName :: ByteString -> Maybe ServerName+decodeServerName "" = Just $ ServerName [] -- dirty hack for servers+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+ 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+ _ -> ServerNameOther (ty, sname)+ return (1 + 2 + B.length sname, name)++------------------------------------------------------------++-- | Max fragment extension with length from 512 bytes to 4096 bytes+--+-- RFC 6066 defines:+-- If a server receives a maximum fragment length negotiation request+-- for a value other than the allowed values, it MUST abort the+-- handshake with an "illegal_parameter" alert.+--+-- So, if a server receives MaxFragmentLengthOther, it must send the alert.+data MaxFragmentLength+ = MaxFragmentLength MaxFragmentEnum+ | MaxFragmentLengthOther Word8+ deriving (Show, Eq)++data MaxFragmentEnum+ = MaxFragment512+ | MaxFragment1024+ | MaxFragment2048+ | MaxFragment4096+ deriving (Show, Eq)++instance Extension MaxFragmentLength where+ extensionID _ = EID_MaxFragmentLength+ extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l+ where+ fromMaxFragmentEnum MaxFragment512 = 1+ fromMaxFragmentEnum MaxFragment1024 = 2+ fromMaxFragmentEnum MaxFragment2048 = 3+ fromMaxFragmentEnum MaxFragment4096 = 4+ extensionEncode (MaxFragmentLengthOther l) = runPut $ putWord8 l+ extensionDecode MsgTClientHello = decodeMaxFragmentLength+ extensionDecode MsgTServerHello = decodeMaxFragmentLength+ extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength+ extensionDecode _ = const Nothing++decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength+decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8+ where+ toMaxFragmentEnum 1 = MaxFragmentLength MaxFragment512+ toMaxFragmentEnum 2 = MaxFragmentLength MaxFragment1024+ toMaxFragmentEnum 3 = MaxFragmentLength MaxFragment2048+ toMaxFragmentEnum 4 = MaxFragmentLength MaxFragment4096+ toMaxFragmentEnum n = MaxFragmentLengthOther n++------------------------------------------------------------++newtype SupportedGroups = SupportedGroups [Group] deriving (Show, Eq)++-- on decode, filter all unknown curves+instance Extension SupportedGroups where+ extensionID _ = EID_SupportedGroups+ extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups+ extensionDecode MsgTClientHello = decodeSupportedGroups+ extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups+ extensionDecode _ = const Nothing++decodeSupportedGroups :: ByteString -> Maybe SupportedGroups+decodeSupportedGroups =+ runGetMaybe (SupportedGroups . map Group <$> getWords16)++------------------------------------------------------------++newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat]+ deriving (Show, Eq)++newtype EcPointFormat = EcPointFormat {fromEcPointFormat :: Word8}+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern EcPointFormat_Uncompressed :: EcPointFormat+pattern EcPointFormat_Uncompressed = EcPointFormat 0+pattern EcPointFormat_AnsiX962_compressed_prime :: EcPointFormat+pattern EcPointFormat_AnsiX962_compressed_prime = EcPointFormat 1+pattern EcPointFormat_AnsiX962_compressed_char2 :: EcPointFormat+pattern EcPointFormat_AnsiX962_compressed_char2 = EcPointFormat 2++instance Show EcPointFormat where+ show EcPointFormat_Uncompressed = "EcPointFormat_Uncompressed"+ show EcPointFormat_AnsiX962_compressed_prime = "EcPointFormat_AnsiX962_compressed_prime"+ show EcPointFormat_AnsiX962_compressed_char2 = "EcPointFormat_AnsiX962_compressed_char2"+ show (EcPointFormat x) = "EcPointFormat " ++ show x+{- FOURMOLU_ENABLE -}++-- on decode, filter all unknown formats+instance Extension EcPointFormatsSupported where+ extensionID _ = EID_EcPointFormats+ extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats+ extensionDecode MsgTClientHello = decodeEcPointFormatsSupported+ extensionDecode MsgTServerHello = decodeEcPointFormatsSupported+ extensionDecode _ = const Nothing++decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported+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]+ deriving (Show, Eq)++instance Extension SignatureAlgorithms where+ extensionID _ = EID_SignatureAlgorithms+ extensionEncode (SignatureAlgorithms algs) =+ runPut $+ putWord16 (fromIntegral (length algs * 2))+ >> mapM_ putSignatureHashAlgorithm algs+ extensionDecode MsgTClientHello = decodeSignatureAlgorithms+ extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms+ extensionDecode _ = const Nothing++decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms+decodeSignatureAlgorithms = runGetMaybe $ do+ len <- getWord16+ sas <-+ getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length"+ when (null sas) $ fail "signature algorithms are empty"+ return $ SignatureAlgorithms sas++------------------------------------------------------------++newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq)++newtype HeartBeatMode = HeartBeatMode {fromHeartBeatMode :: Word8}+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern HeartBeat_PeerAllowedToSend :: HeartBeatMode+pattern HeartBeat_PeerAllowedToSend = HeartBeatMode 1+pattern HeartBeat_PeerNotAllowedToSend :: HeartBeatMode+pattern HeartBeat_PeerNotAllowedToSend = HeartBeatMode 2++instance Show HeartBeatMode where+ show HeartBeat_PeerAllowedToSend = "HeartBeat_PeerAllowedToSend"+ show HeartBeat_PeerNotAllowedToSend = "HeartBeat_PeerNotAllowedToSend"+ show (HeartBeatMode x) = "HeartBeatMode " ++ show x+{- FOURMOLU_ENABLE -}++instance Extension HeartBeat where+ extensionID _ = EID_Heartbeat+ extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode+ extensionDecode MsgTClientHello = decodeHeartBeat+ extensionDecode MsgTServerHello = decodeHeartBeat+ extensionDecode _ = const Nothing++decodeHeartBeat :: ByteString -> Maybe HeartBeat+decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8++------------------------------------------------------------++-- | Application Layer Protocol Negotiation (ALPN)+newtype ApplicationLayerProtocolNegotiation+ = ApplicationLayerProtocolNegotiation [ByteString]+ deriving (Show, Eq)++instance Extension ApplicationLayerProtocolNegotiation where+ extensionID _ = EID_ApplicationLayerProtocolNegotiation+ extensionEncode (ApplicationLayerProtocolNegotiation bytes) =+ runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes+ extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation+ extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation+ extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation+ extensionDecode _ = const Nothing++decodeApplicationLayerProtocolNegotiation+ :: ByteString -> Maybe ApplicationLayerProtocolNegotiation+decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do+ len <- getWord16+ 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)++------------------------------------------------------------++-- | Extended Main Secret+data ExtendedMainSecret = ExtendedMainSecret deriving (Show, Eq)++instance Extension ExtendedMainSecret where+ extensionID _ = EID_ExtendedMainSecret+ extensionEncode ExtendedMainSecret = B.empty+ extensionDecode MsgTClientHello "" = Just ExtendedMainSecret+ extensionDecode MsgTServerHello "" = Just ExtendedMainSecret+ extensionDecode _ _ = Nothing++------------------------------------------------------------++newtype CertificateCompressionAlgorithm+ = CertificateCompressionAlgorithm Word16+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern CCA_Zlib :: CertificateCompressionAlgorithm+pattern CCA_Zlib = CertificateCompressionAlgorithm 1+pattern CCA_Brotli :: CertificateCompressionAlgorithm+pattern CCA_Brotli = CertificateCompressionAlgorithm 2+pattern CCA_Zstd :: CertificateCompressionAlgorithm+pattern CCA_Zstd = CertificateCompressionAlgorithm 3++instance Show CertificateCompressionAlgorithm where+ show CCA_Zlib = "zlib"+ show CCA_Brotli = "brotli"+ show CCA_Zstd = "zstd"+ show (CertificateCompressionAlgorithm n) = "CertificateCompressionAlgorithm " ++ show n+{- FOURMOLU_ENABLE -}++newtype CompressCertificate = CompressCertificate [CertificateCompressionAlgorithm]+ deriving (Show, Eq)++instance Extension CompressCertificate where+ extensionID _ = EID_CompressCertificate+ extensionEncode (CompressCertificate cs) = runPut $ do+ putWord8 $ fromIntegral (length cs * 2)+ mapM_ putCCA cs+ where+ putCCA (CertificateCompressionAlgorithm n) = putWord16 n+ extensionDecode _ = decodeCompressCertificate++decodeCompressCertificate :: ByteString -> Maybe CompressCertificate+decodeCompressCertificate = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ cs <- getList len getCCA+ when (null cs) $ fail "empty list of CertificateCompressionAlgorithm"+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeCompressCertificate: broken length"+ return $ CompressCertificate cs+ where+ getCCA = do+ cca <- CertificateCompressionAlgorithm <$> getWord16+ return (2, cca)++------------------------------------------------------------++newtype RecordSizeLimit = RecordSizeLimit Word16 deriving (Eq, Show)++instance Extension RecordSizeLimit where+ extensionID _ = EID_RecordSizeLimit+ extensionEncode (RecordSizeLimit n) = runPut $ putWord16 n+ extensionDecode _ = decodeRecordSizeLimit++decodeRecordSizeLimit :: ByteString -> Maybe RecordSizeLimit+decodeRecordSizeLimit = runGetMaybe $ do+ r <- RecordSizeLimit <$> getWord16+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeRecordSizeLimit: broken length"+ return r++------------------------------------------------------------++newtype SessionTicket = SessionTicket Ticket+ deriving (Show, Eq)++-- https://datatracker.ietf.org/doc/html/rfc5077#appendix-A+instance Extension SessionTicket where+ extensionID _ = EID_SessionTicket+ extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket+ extensionDecode MsgTClientHello = decodeSessionTicket+ extensionDecode MsgTServerHello = decodeSessionTicket+ extensionDecode _ = const Nothing++decodeSessionTicket :: ByteString -> Maybe SessionTicket+decodeSessionTicket = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)++------------------------------------------------------------++data PskIdentity = PskIdentity ByteString Word32 deriving (Eq)++instance Show PskIdentity where+ show (PskIdentity bs n) = "PskId " ++ showBytesHex bs ++ " " ++ show n++data PreSharedKey+ = PreSharedKeyClientHello [PskIdentity] [ByteString]+ | PreSharedKeyServerHello Int+ deriving (Eq)++instance Show PreSharedKey where+ show (PreSharedKeyClientHello ids bndrs) =+ "PreSharedKey "+ ++ show ids+ ++ " "+ ++ "["+ ++ intercalate ", " (map showBytesHex bndrs)+ ++ "]"+ show (PreSharedKeyServerHello n) = "PreSharedKey " ++ show n++instance Extension PreSharedKey where+ extensionID _ = EID_PreSharedKey+ extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do+ putOpaque16 $ runPut (mapM_ putIdentity ids)+ putOpaque16 $ runPut (mapM_ putBinder bds)+ where+ putIdentity (PskIdentity bs w) = do+ putOpaque16 bs+ putWord32 w+ putBinder = putOpaque8+ extensionEncode (PreSharedKeyServerHello w16) =+ runPut $+ putWord16 $+ fromIntegral w16+ extensionDecode MsgTClientHello = decodePreSharedKeyClientHello+ extensionDecode MsgTServerHello = decodePreSharedKeyServerHello+ extensionDecode _ = const Nothing++decodePreSharedKeyClientHello :: ByteString -> Maybe PreSharedKey+decodePreSharedKeyClientHello = runGetMaybe $ do+ len1 <- fromIntegral <$> getWord16+ identities <- getList len1 getIdentity+ len2 <- fromIntegral <$> getWord16+ binders <- getList len2 getBinder+ return $ PreSharedKeyClientHello identities binders+ where+ getIdentity = do+ identity <- getOpaque16+ age <- getWord32+ let len = 2 + B.length identity + 4+ return (len, PskIdentity identity age)+ getBinder = do+ l <- fromIntegral <$> getWord8+ binder <- getBytes l+ let len = l + 1+ return (len, binder)++decodePreSharedKeyServerHello :: ByteString -> Maybe PreSharedKey+decodePreSharedKeyServerHello =+ runGetMaybe $+ PreSharedKeyServerHello . fromIntegral <$> getWord16++decodePreSharedKey :: ByteString -> Maybe PreSharedKey+decodePreSharedKey bs =+ decodePreSharedKeyClientHello bs+ <|> decodePreSharedKeyServerHello bs++------------------------------------------------------------++newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32)+ deriving (Eq, Show)++instance Extension EarlyDataIndication where+ 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 _ = const Nothing++------------------------------------------------------------++data SupportedVersions+ = SupportedVersionsClientHello [Version]+ | SupportedVersionsServerHello Version+ deriving (Eq)++instance Show SupportedVersions where+ show (SupportedVersionsClientHello vers) = "Versions " ++ show vers+ show (SupportedVersionsServerHello ver) = "Versions " ++ show ver++instance Extension SupportedVersions where+ extensionID _ = EID_SupportedVersions+ extensionEncode (SupportedVersionsClientHello vers) = runPut $ do+ putWord8 (fromIntegral (length vers * 2))+ mapM_ putBinaryVersion vers+ extensionEncode (SupportedVersionsServerHello ver) =+ runPut $+ putBinaryVersion ver+ extensionDecode MsgTClientHello = decodeSupportedVersionsClientHello+ extensionDecode MsgTServerHello = decodeSupportedVersionsServerHello+ extensionDecode _ = const Nothing++decodeSupportedVersionsClientHello :: ByteString -> Maybe SupportedVersions+decodeSupportedVersionsClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ SupportedVersionsClientHello <$> getList len getVer+ where+ getVer = do+ ver <- getBinaryVersion+ return (2, ver)++decodeSupportedVersionsServerHello :: ByteString -> Maybe SupportedVersions+decodeSupportedVersionsServerHello =+ runGetMaybe (SupportedVersionsServerHello <$> getBinaryVersion)++decodeSupportedVersions :: ByteString -> Maybe SupportedVersions+decodeSupportedVersions bs =+ decodeSupportedVersionsClientHello bs+ <|> decodeSupportedVersionsServerHello bs++------------------------------------------------------------++newtype Cookie = Cookie ByteString deriving (Eq, Show)++instance Extension Cookie where+ extensionID _ = EID_Cookie+ extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque+ extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)+ extensionDecode _ = const Nothing++------------------------------------------------------------++newtype PskKexMode = PskKexMode {fromPskKexMode :: Word8} deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern PSK_KE :: PskKexMode+pattern PSK_KE = PskKexMode 0+pattern PSK_DHE_KE :: PskKexMode+pattern PSK_DHE_KE = PskKexMode 1++instance Show PskKexMode where+ show PSK_KE = "PSK_KE"+ show PSK_DHE_KE = "PSK_DHE_KE"+ show (PskKexMode x) = "PskKexMode " ++ show x+{- FOURMOLU_ENABLE -}++newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode]+ deriving (Eq, Show)++instance Extension PskKeyExchangeModes where+ extensionID _ = EID_PskKeyExchangeModes+ extensionEncode (PskKeyExchangeModes pkms) =+ runPut $+ putWords8 $+ map fromPskKexMode pkms+ extensionDecode MsgTClientHello = decodePskKeyExchangeModes+ extensionDecode _ = const Nothing++decodePskKeyExchangeModes :: ByteString -> Maybe PskKeyExchangeModes+decodePskKeyExchangeModes =+ runGetMaybe $+ PskKeyExchangeModes . map PskKexMode <$> getWords8++------------------------------------------------------------++newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName]+ deriving (Eq, Show)++instance Extension CertificateAuthorities where+ extensionID _ = EID_CertificateAuthorities+ extensionEncode (CertificateAuthorities names) =+ runPut $+ putDNames names+ extensionDecode MsgTClientHello = decodeCertificateAuthorities+ extensionDecode MsgTCertificateRequest = decodeCertificateAuthorities+ extensionDecode _ = const Nothing++decodeCertificateAuthorities :: ByteString -> Maybe CertificateAuthorities+decodeCertificateAuthorities =+ runGetMaybe (CertificateAuthorities <$> getDNames)++------------------------------------------------------------++data PostHandshakeAuth = PostHandshakeAuth deriving (Show, Eq)++instance Extension PostHandshakeAuth where+ extensionID _ = EID_PostHandshakeAuth+ extensionEncode _ = B.empty+ extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth+ extensionDecode _ = const Nothing++------------------------------------------------------------++newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm]+ deriving (Show, Eq)++instance Extension SignatureAlgorithmsCert where+ extensionID _ = EID_SignatureAlgorithmsCert+ extensionEncode (SignatureAlgorithmsCert algs) =+ runPut $+ putWord16 (fromIntegral (length algs * 2))+ >> mapM_ putSignatureHashAlgorithm algs+ extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert+ extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert+ extensionDecode _ = const Nothing++decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert+decodeSignatureAlgorithmsCert = runGetMaybe $ do+ len <- getWord16+ SignatureAlgorithmsCert+ <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++------------------------------------------------------------++data KeyShareEntry = KeyShareEntry+ { keyShareEntryGroup :: Group+ , keyShareEntryKeyExchange :: ByteString+ }+ deriving (Eq)++instance Show KeyShareEntry where+ show kse = show $ keyShareEntryGroup kse++getKeyShareEntry :: Get (Int, Maybe KeyShareEntry)+getKeyShareEntry = do+ grp <- Group <$> getWord16+ l <- fromIntegral <$> getWord16+ key <- getBytes l+ let len = l + 4+ return (len, Just $ KeyShareEntry grp key)++putKeyShareEntry :: KeyShareEntry -> Put+putKeyShareEntry (KeyShareEntry (Group grp) key) = do+ putWord16 grp+ putWord16 $ fromIntegral $ B.length key+ putBytes key++data KeyShare+ = KeyShareClientHello [KeyShareEntry]+ | KeyShareServerHello KeyShareEntry+ | KeyShareHRR Group+ deriving (Eq)++{- FOURMOLU_DISABLE -}+instance Show KeyShare where+ show (KeyShareClientHello kses) = "KeyShare " ++ show kses+ show (KeyShareServerHello kse) = "KeyShare " ++ show kse+ show (KeyShareHRR g) = "KeyShareHRR " ++ show g+{- FOURMOLU_ENABLE -}++instance Extension KeyShare where+ extensionID _ = EID_KeyShare+ extensionEncode (KeyShareClientHello kses) = runPut $ do+ let len = sum [B.length key + 4 | KeyShareEntry _ key <- kses]+ putWord16 $ fromIntegral len+ mapM_ putKeyShareEntry kses+ extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse+ extensionEncode (KeyShareHRR (Group grp)) = runPut $ putWord16 grp+ extensionDecode MsgTClientHello = decodeKeyShareClientHello+ extensionDecode MsgTServerHello = decodeKeyShareServerHello+ extensionDecode MsgTHelloRetryRequest = decodeKeyShareHRR+ extensionDecode _ = const Nothing++decodeKeyShareClientHello :: ByteString -> Maybe KeyShare+decodeKeyShareClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord16+ -- len == 0 allows for HRR+ grps <- getList len getKeyShareEntry+ return $ KeyShareClientHello $ catMaybes grps++decodeKeyShareServerHello :: ByteString -> Maybe KeyShare+decodeKeyShareServerHello = runGetMaybe $ do+ (_, ment) <- getKeyShareEntry+ case ment of+ Nothing -> fail "decoding KeyShare for ServerHello"+ Just ent -> return $ KeyShareServerHello ent++decodeKeyShareHRR :: ByteString -> Maybe KeyShare+decodeKeyShareHRR =+ runGetMaybe $+ KeyShareHRR . Group <$> getWord16++decodeKeyShare :: ByteString -> Maybe KeyShare+decodeKeyShare bs =+ decodeKeyShareClientHello bs+ <|> decodeKeyShareServerHello bs+ <|> decodeKeyShareHRR bs++------------------------------------------------------------++newtype EchOuterExtensions = EchOuterExtensions [ExtensionID]+ deriving (Eq, Show)++instance Extension EchOuterExtensions where+ extensionID _ = EID_EchOuterExtensions+ extensionEncode (EchOuterExtensions ids) = runPut $ do+ putWord8 $ fromIntegral (length ids * 2)+ mapM_ (putWord16 . fromExtensionID) ids+ extensionDecode MsgTClientHello = decodeEchOuterExtensions+ extensionDecode _ = const Nothing++decodeEchOuterExtensions :: ByteString -> Maybe EchOuterExtensions+decodeEchOuterExtensions = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ eids <- getList len $ do+ eid <- ExtensionID <$> getWord16+ return (2, eid)+ return $ EchOuterExtensions eids++------------------------------------------------------------++-- | Encrypted Client Hello+data EncryptedClientHello+ = ECHClientHelloInner+ | ECHClientHelloOuter+ { echCipherSuite :: (KDF_ID, AEAD_ID)+ , echConfigId :: ConfigId+ , echEnc :: EncodedPublicKey+ , echPayload :: ByteString+ }+ | ECHEncryptedExtensions ECHConfigList+ | ECHHelloRetryRequest ByteString+ deriving (Eq)++instance Show EncryptedClientHello where+ show ECHClientHelloInner = "ECHClientHelloInner"+ show ECHClientHelloOuter{..} =+ "ECHClientHelloOuter {"+ ++ show (fst echCipherSuite)+ ++ " "+ ++ show (snd echCipherSuite)+ ++ " "+ ++ show echConfigId+ ++ " "+ ++ showBytesHex enc+ ++ " "+ ++ showBytesHex echPayload+ ++ "}"+ where+ EncodedPublicKey enc = echEnc+ show (ECHEncryptedExtensions cnflst) = "ECHEncryptedExtensions " ++ show cnflst+ show (ECHHelloRetryRequest cnfm) = "ECHHelloRetryRequest " ++ showBytesHex cnfm++instance Extension EncryptedClientHello where+ extensionID _ = EID_EncryptedClientHello+ extensionEncode ECHClientHelloInner = runPut $ putWord8 1+ extensionEncode ECHClientHelloOuter{..} = runPut $ do+ putWord8 0+ let (kdfid, aeadid) = echCipherSuite+ putWord16 $ fromKDF_ID kdfid+ putWord16 $ fromAEAD_ID aeadid+ putWord8 echConfigId+ let EncodedPublicKey enc = echEnc+ putOpaque16 enc+ putOpaque16 echPayload+ extensionEncode (ECHEncryptedExtensions cnflist) = encodeECHConfigList cnflist+ extensionEncode (ECHHelloRetryRequest cnfm) = runPut $ putBytes cnfm+ extensionDecode MsgTClientHello = decodeECHClientHello+ extensionDecode MsgTEncryptedExtensions = decodeECHEncryptedExtensions+ extensionDecode MsgTHelloRetryRequest = decodeECHHelloRetryRequest+ extensionDecode _ = const Nothing++decodeECH :: ByteString -> Maybe EncryptedClientHello+decodeECH bs =+ decodeECHClientHello bs+ <|> decodeECHEncryptedExtensions bs+ <|> decodeECHHelloRetryRequest bs++decodeECHClientHello :: ByteString -> Maybe EncryptedClientHello+decodeECHClientHello = runGetMaybe $ do+ typ <- getWord8+ if typ == 1+ then return ECHClientHelloInner+ else do+ kdfid <- KDF_ID <$> getWord16+ aeadid <- AEAD_ID <$> getWord16+ cnfid <- getWord8+ enc <- EncodedPublicKey <$> getOpaque16+ payload <- getOpaque16+ return $+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfid+ , echEnc = enc+ , echPayload = payload+ }++decodeECHEncryptedExtensions :: ByteString -> Maybe EncryptedClientHello+decodeECHEncryptedExtensions bs =+ ECHEncryptedExtensions <$> decodeECHConfigList bs++decodeECHHelloRetryRequest :: ByteString -> Maybe EncryptedClientHello+decodeECHHelloRetryRequest = runGetMaybe $ do+ ECHHelloRetryRequest <$> getBytes 8++------------------------------------------------------------++-- | Secure Renegotiation+data SecureRenegotiation = SecureRenegotiation ByteString ByteString+ deriving (Show, Eq)++instance Extension SecureRenegotiation where+ extensionID _ = EID_SecureRenegotiation+ extensionEncode (SecureRenegotiation cvd svd) =+ runPut $ putOpaque8 (cvd `B.append` svd)+ extensionDecode MsgTClientHello = runGetMaybe $ do+ opaque <- getOpaque8+ return $ SecureRenegotiation opaque ""+ extensionDecode MsgTServerHello = runGetMaybe $ do+ opaque <- getOpaque8+ let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque+ return $ SecureRenegotiation cvd svd+ extensionDecode _ = const Nothing
+ Network/TLS/Extension.hs-boot view
@@ -0,0 +1,22 @@+-- This is a breaker for cyclic imports:+--+-- - Network.TLS.Extension imports Network.TLS.Struct+-- - Network.TLS.Extension imports Network.TLS.Packet+--+-- - Network.TLS.Struct imports Network.TLS.Extension+--+-- - Network.TLS.Packet imports Network.TLS.Struct+--+-- Originally, ExtensionRaw was defined in Network.TLS.Struct and no+-- cyclic imports exist. It is moved into Network.TLS.Extension for+-- pretty-printing, so the cyclic imports happen.+module Network.TLS.Extension where++import Data.ByteString+import Data.Word++data ExtensionRaw = ExtensionRaw ExtensionID ByteString+instance Eq ExtensionRaw+instance Show ExtensionRaw++newtype ExtensionID = ExtensionID {fromExtensionID :: Word16}
Network/TLS/Extra/Cipher.hs view
@@ -1,191 +1,90 @@ module Network.TLS.Extra.Cipher (- -- * cipher suite+ -- * Cipher suite ciphersuite_default, ciphersuite_default_det, ciphersuite_all, ciphersuite_all_det, ciphersuite_strong, ciphersuite_strong_det,+ ciphersuite_dhe_rsa, - -- * individual ciphers- cipher_ECDHE_RSA_AES128GCM_SHA256,- cipher_ECDHE_RSA_AES256GCM_SHA384,- cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256,- cipher_ECDHE_ECDSA_AES128CCM_SHA256,- cipher_ECDHE_ECDSA_AES128CCM8_SHA256,- cipher_ECDHE_ECDSA_AES128GCM_SHA256,- cipher_ECDHE_ECDSA_AES256CCM_SHA256,- cipher_ECDHE_ECDSA_AES256CCM8_SHA256,- cipher_ECDHE_ECDSA_AES256GCM_SHA384,- cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256,- -- TLS 1.3- cipher_TLS13_AES128GCM_SHA256,- cipher_TLS13_AES256GCM_SHA384,- cipher_TLS13_CHACHA20POLY1305_SHA256,- cipher_TLS13_AES128CCM_SHA256,- cipher_TLS13_AES128CCM8_SHA256,-) where+ -- * Individual ciphers -import qualified Data.ByteString as B+ -- ** RFC 5288+ cipher_DHE_RSA_WITH_AES_128_GCM_SHA256,+ cipher_DHE_RSA_WITH_AES_256_GCM_SHA384, -import Data.Tuple (swap)-import Network.TLS.Cipher-import Network.TLS.Types (Version (..))+ -- ** RFC 8446+ 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, -import Crypto.Cipher.AES-import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305-import Crypto.Cipher.Types hiding (Cipher, cipherName)-import Crypto.Error-import qualified Crypto.MAC.Poly1305 as Poly1305-import Crypto.System.CPU+ -- ** RFC 5289+ cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256,+ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384,+ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256,+ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384, -----------------------------------------------------------------+ -- ** RFC 7251+ cipher_ECDHE_ECDSA_WITH_AES_128_CCM,+ cipher_ECDHE_ECDSA_WITH_AES_256_CCM,+ cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8,+ cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8, -aes128ccm :: BulkDirection -> BulkKey -> BulkAEAD-aes128ccm BulkEncrypt key =- let ctx = noFail (cipherInit key) :: AES128- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in swap $ aeadSimpleEncrypt aeadIni ad d 16- )-aes128ccm BulkDecrypt key =- let ctx = noFail (cipherInit key) :: AES128- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in simpleDecrypt aeadIni ad d 16- )+ -- ** RFC 7905+ cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256,+ cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256,+ cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, -aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD-aes128ccm8 BulkEncrypt key =- let ctx = noFail (cipherInit key) :: AES128- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in swap $ aeadSimpleEncrypt aeadIni ad d 8- )-aes128ccm8 BulkDecrypt key =- let ctx = noFail (cipherInit key) :: AES128- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in simpleDecrypt aeadIni ad d 8- )+ -- * Deprecated names -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- )+ -- ** RFC 5288+ cipher_DHE_RSA_AES128GCM_SHA256,+ cipher_DHE_RSA_AES256GCM_SHA384, -aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD-aes256ccm BulkEncrypt key =- let ctx = noFail (cipherInit key) :: AES256- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in swap $ aeadSimpleEncrypt aeadIni ad d 16- )-aes256ccm BulkDecrypt key =- let ctx = noFail (cipherInit key) :: AES256- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in simpleDecrypt aeadIni ad d 16- )+ -- ** RFC 8446+ cipher_TLS13_AES128GCM_SHA256,+ cipher_TLS13_AES256GCM_SHA384,+ cipher_TLS13_CHACHA20POLY1305_SHA256,+ cipher_TLS13_AES128CCM_SHA256,+ cipher_TLS13_AES128CCM8_SHA256, -aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD-aes256ccm8 BulkEncrypt key =- let ctx = noFail (cipherInit key) :: AES256- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in swap $ aeadSimpleEncrypt aeadIni ad d 8- )-aes256ccm8 BulkDecrypt key =- let ctx = noFail (cipherInit key) :: AES256- in ( \nonce d ad ->- let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3- aeadIni = noFail (aeadInit mode ctx nonce)- in simpleDecrypt aeadIni ad d 8- )+ -- ** RFC 5289+ cipher_ECDHE_ECDSA_AES128GCM_SHA256,+ cipher_ECDHE_ECDSA_AES256GCM_SHA384,+ cipher_ECDHE_RSA_AES128GCM_SHA256,+ cipher_ECDHE_RSA_AES256GCM_SHA384, -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- )+ -- ** RFC 7251+ cipher_ECDHE_ECDSA_AES128CCM_SHA256,+ cipher_ECDHE_ECDSA_AES256CCM_SHA256,+ cipher_ECDHE_ECDSA_AES128CCM8_SHA256,+ cipher_ECDHE_ECDSA_AES256CCM8_SHA256, -simpleDecrypt- :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag)-simpleDecrypt aeadIni header input taglen = (output, tag)- where- aead = aeadAppendHeader aeadIni header- (output, aeadFinal) = aeadDecrypt aead input- tag = aeadFinalize aeadFinal taglen+ -- ** RFC 7905+ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256,+ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256,+ cipher_DHE_RSA_CHACHA20POLY1305_SHA256,+) where -noFail :: CryptoFailable a -> a-noFail = throwCryptoError+import Crypto.Cipher.AES+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 Crypto.System.CPU+import Data.ByteArray (convert)+import qualified Data.ByteString as B+import Data.Tuple (swap) -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)- )+import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types ---------------------------------------------------------------- -data CipherSet- = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm- | SetOther [Cipher]---- Preference between AEAD ciphers having equivalent properties is based on--- hardware-acceleration support in the crypton implementation.-sortOptimized :: [CipherSet] -> [Cipher]-sortOptimized = concatMap f- where- f (SetAead gcm chacha ccm)- | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm- | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm- | otherwise = gcm ++ ccm ++ chacha- f (SetOther ciphers) = ciphers---- Order which is deterministic but not optimized for the CPU.-sortDeterministic :: [CipherSet] -> [Cipher]-sortDeterministic = concatMap f- where- f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm- f (SetOther ciphers) = ciphers- -- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to -- weak. This choice of ciphersuites should satisfy most normal needs. For -- otherwise strong ciphers we make little distinction between AES128 and@@ -220,9 +119,9 @@ complement_all :: [Cipher] complement_all =- [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256- , cipher_ECDHE_ECDSA_AES256CCM8_SHA256- , cipher_TLS13_AES128CCM8_SHA256+ [ cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8+ , cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8+ , cipher13_AES_128_CCM_8_SHA256 ] -- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we@@ -244,141 +143,98 @@ sets_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256 SetAead- [cipher_ECDHE_ECDSA_AES256GCM_SHA384]- [cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256]- [cipher_ECDHE_ECDSA_AES256CCM_SHA256]+ [cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384]+ [cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256]+ [cipher_ECDHE_ECDSA_WITH_AES_256_CCM] , SetAead- [cipher_ECDHE_ECDSA_AES128GCM_SHA256]+ [cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256] []- [cipher_ECDHE_ECDSA_AES128CCM_SHA256]+ [cipher_ECDHE_ECDSA_WITH_AES_128_CCM] , SetAead- [cipher_ECDHE_RSA_AES256GCM_SHA384]- [cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256]+ [cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384]+ [cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256] [] , SetAead- [cipher_ECDHE_RSA_AES128GCM_SHA256]+ [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] [] [] , -- TLS13 (listed at the end but version is negotiated first) SetAead- [cipher_TLS13_AES256GCM_SHA384]- [cipher_TLS13_CHACHA20POLY1305_SHA256]+ [cipher13_AES_256_GCM_SHA384]+ [cipher13_CHACHA20_POLY1305_SHA256] [] , SetAead- [cipher_TLS13_AES128GCM_SHA256]+ [cipher13_AES_128_GCM_SHA256] []- [cipher_TLS13_AES128CCM_SHA256]+ [cipher13_AES_128_CCM_SHA256] ] -------------------------------------------------------------------bulk_aes128ccm :: Bulk-bulk_aes128ccm =- Bulk- { bulkName = "AES128CCM"- , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN- , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length- , bulkExplicitIV = 8- , bulkAuthTagLen = 16- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF aes128ccm- }+-- | DHE-RSA cipher suite. This only includes ciphers bound specifically to+-- DHE-RSA so TLS 1.3 ciphers must be added separately.+--+-- @since 2.1.5+ciphersuite_dhe_rsa :: [Cipher]+ciphersuite_dhe_rsa =+ [ cipher_DHE_RSA_WITH_AES_256_GCM_SHA384+ , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+ , cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+ ] -bulk_aes128ccm8 :: Bulk-bulk_aes128ccm8 =- Bulk- { bulkName = "AES128CCM8"- , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN- , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length- , bulkExplicitIV = 8- , bulkAuthTagLen = 8- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF aes128ccm8- }+----------------------------------------------------------------+---------------------------------------------------------------- -bulk_aes128gcm :: Bulk-bulk_aes128gcm =- Bulk- { bulkName = "AES128GCM"- , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN- , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length- , bulkExplicitIV = 8- , bulkAuthTagLen = 16- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF aes128gcm- }+-- A list of cipher suite is found from:+-- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 -bulk_aes256ccm :: Bulk-bulk_aes256ccm =- Bulk- { bulkName = "AES256CCM"- , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN- , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length- , bulkExplicitIV = 8- , bulkAuthTagLen = 16- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF aes256ccm- }+----------------------------------------------------------------+-- RFC 5288 -bulk_aes256ccm8 :: Bulk-bulk_aes256ccm8 =- Bulk- { bulkName = "AES256CCM8"- , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN- , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length- , bulkExplicitIV = 8- , bulkAuthTagLen = 8- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF aes256ccm8+-- TLS_DHE_RSA_WITH_AES_128_GCM_SHA256+cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 :: Cipher+cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 =+ Cipher+ { cipherID = 0x009E+ , cipherName = "TLS_DHE_RSA_WITH_AES_128_GCM_SHA256"+ , cipherBulk = bulk_aes128gcm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } -bulk_aes256gcm :: Bulk-bulk_aes256gcm =- Bulk- { bulkName = "AES256GCM"- , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN- , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length- , bulkExplicitIV = 8- , bulkAuthTagLen = 16- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF aes256gcm- }+{-# DEPRECATED+ cipher_DHE_RSA_AES128GCM_SHA256+ "Use cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 instead"+ #-}+cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher+cipher_DHE_RSA_AES128GCM_SHA256 = cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 -bulk_chacha20poly1305 :: Bulk-bulk_chacha20poly1305 =- Bulk- { bulkName = "CHACHA20POLY1305"- , bulkKeySize = 32- , bulkIVSize = 12 -- RFC 7905 section 2, fixed_iv_length- , bulkExplicitIV = 0- , bulkAuthTagLen = 16- , bulkBlockSize = 0 -- dummy, not used- , bulkF = BulkAeadF chacha20poly1305+-- TLS_DHE_RSA_WITH_AES_256_GCM_SHA384+cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 :: Cipher+cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 =+ Cipher+ { cipherID = 0x009F+ , cipherName = "TLS_DHE_RSA_WITH_AES_256_GCM_SHA384"+ , cipherBulk = bulk_aes256gcm+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 } --- TLS13 bulks are same as TLS12 except they never have explicit IV-bulk_aes128gcm_13 :: Bulk-bulk_aes128gcm_13 = bulk_aes128gcm{bulkIVSize = 12, bulkExplicitIV = 0}--bulk_aes256gcm_13 :: Bulk-bulk_aes256gcm_13 = bulk_aes256gcm{bulkIVSize = 12, bulkExplicitIV = 0}--bulk_aes128ccm_13 :: Bulk-bulk_aes128ccm_13 = bulk_aes128ccm{bulkIVSize = 12, bulkExplicitIV = 0}--bulk_aes128ccm8_13 :: Bulk-bulk_aes128ccm8_13 = bulk_aes128ccm8{bulkIVSize = 12, bulkExplicitIV = 0}---------------------------------------------------------------------- A list of cipher suite is found from:--- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4+{-# DEPRECATED+ cipher_DHE_RSA_AES256GCM_SHA384+ "Use cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 instead"+ #-}+cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher+cipher_DHE_RSA_AES256GCM_SHA384 = cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 ---------------------------------------------------------------- -- RFC 8446 -cipher_TLS13_AES128GCM_SHA256 :: Cipher-cipher_TLS13_AES128GCM_SHA256 =+-- TLS_AES_128_GCM_SHA256+cipher13_AES_128_GCM_SHA256 :: Cipher+cipher13_AES_128_GCM_SHA256 = Cipher { cipherID = 0x1301 , cipherName = "TLS_AES_128_GCM_SHA256"@@ -389,8 +245,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_AES256GCM_SHA384 :: Cipher-cipher_TLS13_AES256GCM_SHA384 =+cipher_TLS13_AES128GCM_SHA256 :: Cipher+cipher_TLS13_AES128GCM_SHA256 = cipher13_AES_128_GCM_SHA256+{-# DEPRECATED+ cipher_TLS13_AES128GCM_SHA256+ "Use cipher13_AES_128_GCM_SHA256 instead"+ #-}++-- TLS_AES_256_GCM_SHA384+cipher13_AES_256_GCM_SHA384 :: Cipher+cipher13_AES_256_GCM_SHA384 = Cipher { cipherID = 0x1302 , cipherName = "TLS_AES_256_GCM_SHA384"@@ -401,8 +265,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher-cipher_TLS13_CHACHA20POLY1305_SHA256 =+cipher_TLS13_AES256GCM_SHA384 :: Cipher+cipher_TLS13_AES256GCM_SHA384 = cipher13_AES_256_GCM_SHA384+{-# DEPRECATED+ cipher_TLS13_AES256GCM_SHA384+ "Use cipher13_AES_256_GCM_SHA384 instead"+ #-}++-- TLS_CHACHA20_POLY1305_SHA256+cipher13_CHACHA20_POLY1305_SHA256 :: Cipher+cipher13_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0x1303 , cipherName = "TLS_CHACHA20_POLY1305_SHA256"@@ -413,8 +285,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_AES128CCM_SHA256 :: Cipher-cipher_TLS13_AES128CCM_SHA256 =+cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher+cipher_TLS13_CHACHA20POLY1305_SHA256 = cipher13_CHACHA20_POLY1305_SHA256+{-# DEPRECATED+ cipher_TLS13_CHACHA20POLY1305_SHA256+ "Use cipher13_CHACHA20_POLY1305_SHA256 instead"+ #-}++-- TLS_AES_128_CCM_SHA256+cipher13_AES_128_CCM_SHA256 :: Cipher+cipher13_AES_128_CCM_SHA256 = Cipher { cipherID = 0x1304 , cipherName = "TLS_AES_128_CCM_SHA256"@@ -425,8 +305,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_AES128CCM8_SHA256 :: Cipher-cipher_TLS13_AES128CCM8_SHA256 =+cipher_TLS13_AES128CCM_SHA256 :: Cipher+cipher_TLS13_AES128CCM_SHA256 = cipher13_AES_128_CCM_SHA256+{-# DEPRECATED+ cipher_TLS13_AES128CCM_SHA256+ "Use cipher13_AES_128_CCM_SHA256 instead"+ #-}++-- TLS_AES_128_CCM_8_SHA256+cipher13_AES_128_CCM_8_SHA256 :: Cipher+cipher13_AES_128_CCM_8_SHA256 = Cipher { cipherID = 0x1305 , cipherName = "TLS_AES_128_CCM_8_SHA256"@@ -437,11 +325,19 @@ , cipherMinVer = Just TLS13 } +cipher_TLS13_AES128CCM8_SHA256 :: Cipher+cipher_TLS13_AES128CCM8_SHA256 = cipher13_AES_128_CCM_8_SHA256+{-# DEPRECATED+ cipher_TLS13_AES128CCM8_SHA256+ "Use cipher13_AES_128_CCM_8_SHA256 instead"+ #-}+ ---------------------------------------------------------------- -- GCM: RFC 5289 -cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES128GCM_SHA256 =+-- TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256+cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 :: Cipher+cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 = Cipher { cipherID = 0xC02B , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256"@@ -452,8 +348,16 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } -cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher-cipher_ECDHE_ECDSA_AES256GCM_SHA384 =+cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128GCM_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256+{-# DEPRECATED+ cipher_ECDHE_ECDSA_AES128GCM_SHA256+ "Use cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 instead"+ #-}++-- TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384+cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 :: Cipher+cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 = Cipher { cipherID = 0xC02C , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384"@@ -464,8 +368,16 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } -cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher-cipher_ECDHE_RSA_AES128GCM_SHA256 =+cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher+cipher_ECDHE_ECDSA_AES256GCM_SHA384 = cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384+{-# DEPRECATED+ cipher_ECDHE_ECDSA_AES256GCM_SHA384+ "Use cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 instead"+ #-}++-- TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256+cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 :: Cipher+cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 = Cipher { cipherID = 0xC02F , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256"@@ -476,8 +388,16 @@ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } -cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher-cipher_ECDHE_RSA_AES256GCM_SHA384 =+cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher+cipher_ECDHE_RSA_AES128GCM_SHA256 = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+{-# DEPRECATED+ cipher_ECDHE_RSA_AES128GCM_SHA256+ "Use cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 instead"+ #-}++-- TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384+cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 :: Cipher+cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 = Cipher { cipherID = 0xC030 , cipherName = "TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384"@@ -488,11 +408,19 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } +cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher+cipher_ECDHE_RSA_AES256GCM_SHA384 = cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384+{-# DEPRECATED+ cipher_ECDHE_RSA_AES256GCM_SHA384+ "Use cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 instead"+ #-}+ ---------------------------------------------------------------- -- CCM/ECC: RFC 7251 -cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES128CCM_SHA256 =+-- TLS_ECDHE_ECDSA_WITH_AES_128_CCM+cipher_ECDHE_ECDSA_WITH_AES_128_CCM :: Cipher+cipher_ECDHE_ECDSA_WITH_AES_128_CCM = Cipher { cipherID = 0xC0AC , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CCM"@@ -503,8 +431,16 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } -cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES256CCM_SHA256 =+cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CCM_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_128_CCM+{-# DEPRECATED+ cipher_ECDHE_ECDSA_AES128CCM_SHA256+ "User cipher_ECDHE_ECDSA_WITH_AES_128_CCM instead"+ #-}++-- TLS_ECDHE_ECDSA_WITH_AES_256_CCM+cipher_ECDHE_ECDSA_WITH_AES_256_CCM :: Cipher+cipher_ECDHE_ECDSA_WITH_AES_256_CCM = Cipher { cipherID = 0xC0AD , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CCM"@@ -515,8 +451,16 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } -cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES128CCM8_SHA256 =+cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES256CCM_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_256_CCM+{-# DEPRECATED+ cipher_ECDHE_ECDSA_AES256CCM_SHA256+ "Use cipher_ECDHE_ECDSA_WITH_AES_256_CCM instead"+ #-}++-- TLS_ECDHE_ECDSA_WITH_AES_128_CCM_8+cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 :: Cipher+cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 = Cipher { cipherID = 0xC0AE , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CCM_8"@@ -527,8 +471,16 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } -cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES256CCM8_SHA256 =+cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8+{-# DEPRECATED+ cipher_ECDHE_ECDSA_AES128CCM8_SHA256+ "Use cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 instead"+ #-}++-- TLS_ECDHE_ECDSA_WITH_AES_256_CCM_8+cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 :: Cipher+cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 = Cipher { cipherID = 0xC0AF , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CCM_8"@@ -539,11 +491,19 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } +cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8+{-# DEPRECATED+ cipher_ECDHE_ECDSA_AES256CCM8_SHA256+ "Use cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 instead"+ #-}+ ---------------------------------------------------------------- -- RFC 7905 -cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher-cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 =+-- TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256+cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 :: Cipher+cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0xCCA8 , cipherName = "TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256"@@ -554,8 +514,16 @@ , cipherMinVer = Just TLS12 } -cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher-cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 =+cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher+cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256+{-# DEPRECATED+ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256+ "Use cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 instead"+ #-}++-- TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256+cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 :: Cipher+cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0xCCA9 , cipherName = "TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256"@@ -565,3 +533,283 @@ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 }++cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher+cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256+{-# DEPRECATED+ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256+ "Use cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 instead"+ #-}++-- TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 :: Cipher+cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 =+ Cipher+ { cipherID = 0xCCAA+ , cipherName = "TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12+ }++cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher+cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+{-# DEPRECATED+ cipher_DHE_RSA_CHACHA20POLY1305_SHA256+ "Use cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 instead"+ #-}++----------------------------------------------------------------+----------------------------------------------------------------++data CipherSet+ = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm+ | SetOther [Cipher]++-- Preference between AEAD ciphers having equivalent properties is based on+-- hardware-acceleration support in the crypton implementation.+sortOptimized :: [CipherSet] -> [Cipher]+sortOptimized = concatMap f+ where+ f (SetAead gcm chacha ccm)+ | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm+ | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm+ | otherwise = gcm ++ ccm ++ chacha+ f (SetOther ciphers) = ciphers++-- Order which is deterministic but not optimized for the CPU.+sortDeterministic :: [CipherSet] -> [Cipher]+sortDeterministic = concatMap f+ where+ f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm+ f (SetOther ciphers) = ciphers++----------------------------------------------------------------++aes128ccm :: BulkDirection -> BulkKey -> BulkAEAD+aes128ccm BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 16+ )+aes128ccm BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 16+ )++aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD+aes128ccm8 BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 8+ )+aes128ccm8 BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ 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 = aesgcm++aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD+aes256gcm = aesgcm+++aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD+aes256ccm BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 16+ )+aes256ccm BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 16+ )++aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD+aes256ccm8 BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 8+ )+aes256ccm8 BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 8+ )++simpleDecrypt+ :: AEAD cipher -> ByteString -> ByteString -> Int -> (ByteString, AuthTag)+simpleDecrypt aeadIni header input taglen = (output, tag)+ where+ aead = aeadAppendHeader aeadIni header+ (output, aeadFinal) = aeadDecrypt aead input+ tag = aeadFinalize aeadFinal taglen++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 =+ 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)++----------------------------------------------------------------++bulk_aes128ccm :: Bulk+bulk_aes128ccm =+ Bulk+ { bulkName = "AES128CCM"+ , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length+ , bulkExplicitIV = 8+ , bulkAuthTagLen = 16+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes128ccm+ }++bulk_aes128ccm8 :: Bulk+bulk_aes128ccm8 =+ Bulk+ { bulkName = "AES128CCM8"+ , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length+ , bulkExplicitIV = 8+ , bulkAuthTagLen = 8+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes128ccm8+ }++bulk_aes128gcm :: Bulk+bulk_aes128gcm =+ Bulk+ { bulkName = "AES128GCM"+ , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length+ , bulkExplicitIV = 8+ , bulkAuthTagLen = 16+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes128gcm+ }++bulk_aes256ccm :: Bulk+bulk_aes256ccm =+ Bulk+ { bulkName = "AES256CCM"+ , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length+ , bulkExplicitIV = 8+ , bulkAuthTagLen = 16+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes256ccm+ }++bulk_aes256ccm8 :: Bulk+bulk_aes256ccm8 =+ Bulk+ { bulkName = "AES256CCM8"+ , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length+ , bulkExplicitIV = 8+ , bulkAuthTagLen = 8+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes256ccm8+ }++bulk_aes256gcm :: Bulk+bulk_aes256gcm =+ Bulk+ { bulkName = "AES256GCM"+ , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length+ , bulkExplicitIV = 8+ , bulkAuthTagLen = 16+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes256gcm+ }++bulk_chacha20poly1305 :: Bulk+bulk_chacha20poly1305 =+ Bulk+ { bulkName = "CHACHA20POLY1305"+ , bulkKeySize = 32+ , bulkIVSize = 12 -- RFC 7905 section 2, fixed_iv_length+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 16+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF chacha20poly1305+ }++-- TLS13 bulks are same as TLS12 except they never have explicit IV+bulk_aes128gcm_13 :: Bulk+bulk_aes128gcm_13 = bulk_aes128gcm{bulkIVSize = 12, bulkExplicitIV = 0}++bulk_aes256gcm_13 :: Bulk+bulk_aes256gcm_13 = bulk_aes256gcm{bulkIVSize = 12, bulkExplicitIV = 0}++bulk_aes128ccm_13 :: Bulk+bulk_aes128ccm_13 = bulk_aes128ccm{bulkIVSize = 12, bulkExplicitIV = 0}++bulk_aes128ccm8_13 :: Bulk+bulk_aes128ccm8_13 = bulk_aes128ccm8{bulkIVSize = 12, bulkExplicitIV = 0}
+ 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.hs view
@@ -8,11 +8,10 @@ ) where import Network.TLS.Context.Internal-import Network.TLS.Struct- import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.Struct import Control.Monad.State.Strict @@ -26,9 +25,9 @@ -- This is called automatically by 'recvData', in a context where the read lock -- is already taken. So contrary to 'handshake' above, here we only need to -- call withWriteLock.-handshakeWith :: MonadIO m => Context -> Handshake -> m ()-handshakeWith ctx hs =+handshakeWith :: MonadIO m => Context -> HandshakeR -> m ()+handshakeWith ctx hsr = liftIO $ withWriteLock ctx $ handleException ctx $- doHandshakeWith_ (ctxRoleParams ctx) ctx hs+ doHandshakeWith_ (ctxRoleParams ctx) ctx hsr
Network/TLS/Handshake/Certificate.hs view
@@ -3,13 +3,21 @@ badCertificate, rejectOnException, verifyLeafKeyUsage,+ verifyLeafKeyUsagePurpose, 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 Data.X509 (+ ExtExtendedKeyUsage (..),+ ExtKeyUsage (..),+ ExtKeyUsageFlag,+ ExtKeyUsagePurpose (..),+ extensionGet,+ )+ import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509@@ -30,7 +38,7 @@ 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 ()@@ -45,6 +53,19 @@ case extensionGet (certExtensions cert) of Nothing -> True -- unrestricted cert Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags++verifyLeafKeyUsagePurpose+ :: MonadIO m => ExtKeyUsagePurpose -> CertificateChain -> m ()+verifyLeafKeyUsagePurpose _ (CertificateChain []) = return ()+verifyLeafKeyUsagePurpose validPurpose (CertificateChain (signed : _)) =+ unless verified $+ badCertificate $+ "certificate is not allowed for " ++ show validPurpose+ where+ cert = getCertificate signed+ verified = case extensionGet (certExtensions cert) of+ Nothing -> True+ Just (ExtExtendedKeyUsage purposes) -> validPurpose `elem` purposes extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert
Network/TLS/Handshake/Client.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client ( handshakeClient,@@ -10,6 +11,7 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Client.ClientHello+import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Client.ServerHello import Network.TLS.Handshake.Client.TLS12 import Network.TLS.Handshake.Client.TLS13@@ -25,8 +27,9 @@ ---------------------------------------------------------------- -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()-handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx+handshakeClientWith+ :: ClientParams -> Context -> HandshakeR -> IO ()+handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx handshakeClientWith _ _ _ = throwCore $ Error_Protocol@@ -37,16 +40,34 @@ -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do- groups <- case clientWantSessionResume cparams of- Nothing -> return groupsSupported- Just (_, sdata) -> case sessionGroup sdata of- Nothing -> return [] -- TLS 1.2 or earlier+ grps <- case clientSessions cparams of+ [] ->+ return $+ Groups+ { grpsSupported = groupsSupported+ , grpsSelected = groupsSelected+ }+ (_, sdata) : _ -> case sessionGroup sdata of+ Nothing ->+ -- TLS 1.2 or earlier+ return $+ Groups+ { grpsSupported = groupsSupported -- for ciphers+ , grpsSelected = []+ } Just grp- | grp `elem` groupsSupported -> return $ grp : filter (/= grp) groupsSupported+ | grp `elem` groupsSupported -> do+ let supported = grp : filter (/= grp) groupsSupported+ return $+ Groups+ { grpsSupported = supported+ , grpsSelected = [grp]+ } | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect"- handshake cparams ctx groups Nothing+ handshake cparams ctx grps Nothing where groupsSupported = supportedGroups (ctxSupported ctx)+ groupsSelected = onSelectKeyShareGroups (clientHooks cparams) groupsSupported -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a@@ -58,10 +79,10 @@ handshake :: ClientParams -> Context- -> [Group]+ -> Groups -> Maybe (ClientRandom, Session, Version) -> IO ()-handshake cparams ctx groups mparams = do+handshake cparams ctx grps@Groups{..} mparams = do -------------------------------- -- Sending ClientHello pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx@@ -69,21 +90,21 @@ let async = rtt0 && not (ctxQUICMode ctx) when async $ do chSentTime <- getCurrentTimeFromBase- asyncServerHello13 cparams ctx groupToSend chSentTime+ asyncServerHello13 cparams ctx grpsSelected chSentTime updateMeasure ctx incrementNbHandshakes- crand <- sendClientHello cparams ctx groups mparams pskinfo+ crand <-+ sendClientHello cparams ctx grps mparams pskinfo -------------------------------- -- Receiving ServerHello unless async $ do- (ver, hss, hrr) <- receiveServerHello cparams ctx mparams- --------------------------------+ (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams -- Switching to HRR, TLS 1.2 or TLS 1.3 case ver of TLS13 | hrr ->- helloRetry cparams ctx mparams ver crand $ drop 1 groups+ helloRetry cparams ctx mparams ver crand grpsSupported grpsSelected | otherwise -> do- recvServerSecondFlight13 cparams ctx groupToSend+ recvServerSecondFlight13 cparams ctx grpsSelected sendClientSecondFlight13 cparams ctx _ | rtt0 ->@@ -92,31 +113,9 @@ "server denied TLS 1.3 when connecting with early data" HandshakeFailure | otherwise -> do- recvServerFirstFlight12 cparams ctx hss+ recvServerFirstFlight12 cparams ctx hbs sendClientSecondFlight12 cparams ctx- recvServerSecondFlight12 ctx- where- groupToSend = listToMaybe groups--receiveServerHello- :: ClientParams- -> Context- -> Maybe (ClientRandom, Session, Version)- -> IO (Version, [Handshake], Bool)-receiveServerHello cparams ctx mparams = do- chSentTime <- getCurrentTimeFromBase- hss <- recvServerHello cparams ctx- setRTT ctx chSentTime- ver <- usingState_ ctx getVersion- unless (maybe True (\(_, _, v) -> v == ver) mparams) $- throwCore $- Error_Protocol "version changed after hello retry" IllegalParameter- -- recvServerHello sets TLS13HRR according to the server random.- -- For 1st server hello, getTLS13HR returns True if it is HRR and- -- False otherwise. For 2nd server hello, getTLS13HR returns- -- False since it is NOT HRR.- hrr <- usingState_ ctx getTLS13HRR- return (ver, hss, hrr)+ recvServerSecondFlight12 cparams ctx ---------------------------------------------------------------- @@ -127,24 +126,46 @@ -> Version -> ClientRandom -> [Group]+ -> [Group] -> IO ()-helloRetry cparams ctx mparams ver crand groups = do- when (null groups) $+helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do+ when (null groupsSupported) $ throwCore $- Error_Protocol "group is exhausted in the client side" IllegalParameter+ Error_Protocol "no supported groups on the client side" IllegalParameter when (isJust mparams) $ throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup)- | selectedGroup `elem` groups -> do+ -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups+ -- and MUST NOT already have been offered in the initial key_share.+ | selectedGroup `elem` groupsSupported+ && selectedGroup `notElem` groupsSelected -> do usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxRecordState ctx let cparams' = cparams{clientUseEarlyData = False} runPacketFlight ctx $ sendChangeCipherSpec13 ctx clientSession <- tls13stSession <$> getTLS13State ctx- handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))+ -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical+ -- to the first except for the specific listed changes.+ -- supported_groups is NOT on that list, so it must be unchanged.+ let grps =+ Groups+ { grpsSupported = groupsSupported+ , grpsSelected = [selectedGroup]+ }++ handshake+ cparams'+ ctx+ grps+ (Just (crand, clientSession, ver))+ | selectedGroup `elem` groupsSelected ->+ throwCore $+ Error_Protocol+ "server selected a group already offered in key_share"+ IllegalParameter | otherwise -> throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -1,12 +1,28 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.ClientHello ( sendClientHello, getPreSharedKeyInfo,+ Groups (..), ) where +import qualified Control.Exception as E+import Crypto.HPKE hiding (CipherText, PlainText)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import Network.TLS.ECH.Config+import System.Random++#if !MIN_VERSION_random(1,3,0)+import Data.ByteString.Internal (unsafeCreate)+import Foreign.Ptr+import Foreign.Storable+#endif+ import Network.TLS.Cipher-import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension@@ -14,10 +30,10 @@ import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Control-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Packet hiding (getExtensions)@@ -28,16 +44,26 @@ ---------------------------------------------------------------- +data Groups = Groups+ { grpsSupported :: [Group]+ -- ^ For supported_group, head is identical to key_share+ , grpsSelected :: [Group]+ -- ^ For key_share+ }+ deriving (Eq, Show)++----------------------------------------------------------------+ sendClientHello :: ClientParams -> Context- -> [Group]+ -> Groups -> Maybe (ClientRandom, Session, Version) -> PreSharedKeyInfo -> IO ClientRandom-sendClientHello cparams ctx groups mparams pskinfo = do- crand <- generateClientHelloParams mparams- sendClientHello' cparams ctx groups crand pskinfo+sendClientHello cparams ctx grps mparams pskinfo = do+ crand <- generateClientHelloParams mparams -- Inner for ECH+ sendClientHello' cparams ctx grps crand pskinfo return crand where highestVer = maximum $ supportedVersions $ ctxSupported ctx@@ -51,9 +77,9 @@ return crand generateClientHelloParams Nothing = do crand <- clientRandom ctx- let paramSession = case clientWantSessionResume cparams of- Nothing -> Session Nothing- Just (sidOrTkt, sdata)+ let paramSession = case clientSessions cparams of+ [] -> Session Nothing+ (sidOrTkt, sdata) : _ | sessionVersion sdata >= TLS13 -> Session Nothing | ems == RequireEMS && noSessionEMS -> Session Nothing | isTicket sidOrTkt -> Session $ Just $ toSessionID sidOrTkt@@ -76,23 +102,75 @@ sendClientHello' :: ClientParams -> Context- -> [Group]+ -> Groups -> ClientRandom- -> PreSharedKeyInfo+ -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32)+ , Maybe CipherChoice+ , Bool+ ) -> IO ()-sendClientHello' cparams ctx groups crand (pskInfo, rtt0info, rtt0) = do+sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer clientSession <- tls13stSession <$> getTLS13State ctx hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer- let cipherIds = map cipherID ciphers- compIds = map compressionID compressions- mkClientHello exts = ClientHello ver crand compIds $ CH clientSession cipherIds exts+ let cipherIds = map (CipherId . cipherID) ciphers+ mkClientHello exts =+ CH+ { chVersion = ver+ , chRandom = crand+ , chSession = clientSession+ , chCiphers = cipherIds+ , chComps = [0]+ , chExtensions = exts+ }+ setMyRecordLimit ctx $ limitRecordSize $ sharedLimit $ ctxShared ctx extensions0 <- catMaybes <$> getExtensions let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0- extensions <- adjustExtentions extensions1 $ mkClientHello extensions1- sendPacket12 ctx $ Handshake [mkClientHello extensions]+ extensions <- adjustPreSharedKeyExt extensions1 $ mkClientHello extensions1+ let ch0 = mkClientHello extensions+ updateTranscriptHashI ctx "ClientHelloI" $ encodeHandshake $ ClientHello ch0+ let nhpks = supportedHPKE $ clientSupported cparams+ echcnfs = sharedECHConfigList $ clientShared cparams+ mEchParams = lookupECHConfigList nhpks echcnfs+ ch <-+ if clientUseECH cparams+ then case mEchParams of+ Nothing -> do+ if hrr+ then do+ (chI, _) <- fromJust <$> usingHState ctx getClientHello+ let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)}+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0' []+ return ch0'+ else do+ gEchExt <- greasingEchExt+ let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)}+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0' []+ return ch0'+ Just echParams -> do+ let encoded = encodeHandshake $ ClientHello ch0+ usingHState ctx $ setClientHello ch0 [encoded]+ mcrandO <- usingHState ctx getOuterClientRandom+ crandO <- case mcrandO of+ Nothing -> clientRandom ctx+ Just x -> return x+ usingHState ctx $ do+ setClientRandom crandO+ setOuterClientRandom $ Just crandO+ mpskExt <- randomPreSharedKeyExt+ createEncryptedClientHello ctx ch0 echParams crandO mpskExt+ else do+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0 []+ return ch0+ sendPacket12 ctx $ Handshake [ClientHello ch] [] mEarlySecInfo <- case rtt0info of Nothing -> return Nothing Just info -> Just <$> getEarlySecretInfo info@@ -101,11 +179,9 @@ modifyTLS13State ctx $ \st -> st{tls13stSentExtensions = sentExtensions} where ciphers = supportedCiphers $ ctxSupported ctx- compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMainSecret $ ctxSupported ctx- groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations@@ -117,73 +193,51 @@ -- (not always present) have length > 0. getExtensions = sequence- [ sniExtension- , secureReneg- , alpnExtension- , emsExtension- , groupExtension- , ecPointExtension- , sessionTicketExtension- , signatureAlgExtension- , -- , heartbeatExtension- versionExtension- , earlyDataExtension- , keyshareExtension- , cookieExtension- , postHandshakeAuthExtension- , pskExchangeModeExtension- , preSharedKeyExtension -- MUST be last (RFC 8446)+ [ {- 0xfe0d -} echExt+ , {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x0b -} ecPointExt+ , {- 0x0d -} signatureAlgExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1b -} compCertExt+ , {- 0x1c -} recordSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0x2a -} earlyDataExt+ , {- 0x2b -} versionExt+ , {- 0x2c -} cookieExt+ , {- 0x2d -} pskExchangeModeExt+ , {- 0x31 -} postHandshakeAuthExt+ , {- 0x33 -} keyShareExt+ , {- 0xff01 -} secureRenegExt+ , {- 0x29 -} preSharedKeyExt -- MUST be last (RFC 8446) ] - toExtensionRaw :: Extension e => e -> ExtensionRaw- toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext)+ -------------------- - secureReneg =- if supportedSecureRenegotiation $ ctxSupported ctx- then do- cvd <- usingState_ ctx $ getVerifyData ClientRole- return $ Just $ toExtensionRaw $ SecureRenegotiation cvd ""- else return Nothing- alpnExtension = do- mprotos <- onSuggestALPN $ clientHooks cparams- case mprotos of- Nothing -> return Nothing- Just protos -> do- usingState_ ctx $ setClientALPNSuggest protos- return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos- emsExtension =- return $- if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)- then Nothing- else Just $ toExtensionRaw ExtendedMainSecret- sniExtension =- if clientUseServerNameIndication cparams+ -- RFC 6066 Section 3: HostName is <1..2^16-1>, so no server_name+ -- is sent for an empty name.+ sniExt =+ 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 - groupExtension =- return $- Just $- toExtensionRaw $- SupportedGroups (supportedGroups $ ctxSupported ctx)- ecPointExtension =+ -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond+ -- to a group offered in the "supported_groups" extension and MUST+ -- appear in the same order.+ groupExt = return $ Just $ toExtensionRaw $ SupportedGroups grpsSupported++ ecPointExt = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]- -- [EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]- -- heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend - sessionTicketExtension = do- case clientWantSessionResume cparams of- Just (sidOrTkt, _)- | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt- _ -> return $ Just $ toExtensionRaw $ SessionTicket ""-- signatureAlgExtension =+ signatureAlgExt = return $ Just $ toExtensionRaw $@@ -191,74 +245,140 @@ supportedHashSignatures $ clientSupported cparams - versionExtension- | tls13 = do- let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx- return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers- | otherwise = return Nothing-- -- FIXME- keyshareExtension- | tls13 = case groupToSend of+ alpnExt = do+ mprotos <- onSuggestALPN $ clientHooks cparams+ case mprotos of Nothing -> return Nothing- Just grp -> do- (cpri, ent) <- makeClientKeyShare ctx grp- usingHState ctx $ setGroupPrivate cpri- return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]- | otherwise = return Nothing+ Just protos -> do+ usingState_ ctx $ setClientALPNSuggest protos+ return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos - preSharedKeyExtension =- case pskInfo of- Nothing -> return Nothing- Just (identity, _, choice, obfAge) ->- let zero = cZero choice- pskIdentity = PskIdentity identity obfAge- offeredPsks = PreSharedKeyClientHello [pskIdentity] [zero]- in return $ Just $ toExtensionRaw offeredPsks+ emsExt =+ return $+ if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)+ then Nothing+ else Just $ toExtensionRaw ExtendedMainSecret - pskExchangeModeExtension- | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]- | otherwise = return Nothing+ compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib]) - earlyDataExtension+ recordSizeLimitExt = case limitRecordSize $ sharedLimit $ ctxShared ctx of+ Nothing -> return Nothing+ Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz++ sessionTicketExt =+ case clientSessions cparams of+ (sidOrTkt, _) : _+ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt+ _+ | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket ""+ | otherwise -> return $ Nothing++ earlyDataExt | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) | otherwise = return Nothing - cookieExtension = do+ versionExt+ | clientUseECH cparams = do+ let vers = supportedVersions $ ctxSupported ctx+ if TLS13 `elem` vers+ then+ return $ Just $ toExtensionRaw $ SupportedVersionsClientHello [TLS13]+ else+ throwCore $ Error_Misc "TLS 1.3 must be specified for Encrypted Client Hello"+ | tls13 = do+ let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx+ return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers+ | otherwise = return Nothing++ cookieExt = do mcookie <- usingState_ ctx getTLS13Cookie case mcookie of Nothing -> return Nothing Just cookie -> return $ Just $ toExtensionRaw cookie - postHandshakeAuthExtension+ pskExchangeModeExt+ | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]+ | otherwise = return Nothing++ postHandshakeAuthExt | ctxQUICMode ctx = return Nothing | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth | otherwise = return Nothing - adjustExtentions exts ch =+ keyShareExt+ | tls13 = do+ (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected+ usingHState ctx $ setGroupPrivate grpCpris+ return $ Just $ toExtensionRaw $ KeyShareClientHello ents+ | otherwise = return Nothing++ secureRenegExt =+ if supportedSecureRenegotiation $ ctxSupported ctx+ then do+ VerifyData cvd <- usingState_ ctx $ getVerifyData ClientRole+ return $ Just $ toExtensionRaw $ SecureRenegotiation cvd ""+ else return Nothing++ -- ECHClientHelloInner should be replaced if ECHConfigList is not available.+ echExt+ | 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++ 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++ ----------------------------------------++ adjustPreSharedKeyExt exts ch =+ case pskInfo of Nothing -> return exts- Just (_, sdata, choice, _) -> do+ Just (identities, sdata, choice, _) -> do let psk = sessionSecret sdata earlySecret = initEarlySecret choice (Just psk) usingHState ctx $ setTLS13EarlySecret earlySecret- let ech = encodeHandshake ch+ let ech = encodeHandshake $ ClientHello ch h = cHash choice- siz = hashDigestSize h- binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech)+ 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 binder+ withBinders = replacePSKBinder withoutBinders binders return exts' getEarlySecretInfo choice = do let usedCipher = cCipher choice usedHash = cHash choice Just earlySecret <- usingHState ctx getTLS13EarlySecret- -- Client hello is stored in hstHandshakeDigest- -- But HandshakeDigestContext is not created yet.- earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False+ earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) let clientEarlySecret = pairClient earlyKey unless (ctxQUICMode ctx) $ do runPacketFlight ctx $ sendChangeCipherSpec13 ctx@@ -271,7 +391,10 @@ ---------------------------------------------------------------- type PreSharedKeyInfo =- (Maybe (SessionID, SessionData, CipherChoice, Second), Maybe CipherChoice, Bool)+ ( Maybe ([SessionIDorTicket], SessionData, CipherChoice, Second)+ , Maybe CipherChoice+ , Bool+ ) getPreSharedKeyInfo :: ClientParams@@ -286,31 +409,210 @@ ciphers = supportedCiphers $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13- sessionAndCipherToResume13 = do- guard tls13- (sid, sdata) <- clientWantSessionResume cparams- guard (sessionVersion sdata >= TLS13)- let cid = sessionCipher sdata- sCipher <- find (\c -> cipherID c == cid) ciphers- return (sid, sdata, sCipher) - getPskInfo =- case sessionAndCipherToResume13 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+ 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++----------------------------------------------------------------++createEncryptedClientHello+ :: Context+ -> ClientHello+ -> (KDF_ID, AEAD_ID, ECHConfig)+ -> ClientRandom+ -> Maybe ExtensionRaw+ -> IO ClientHello+createEncryptedClientHello ctx ch0@CH{..} echParams@(kdfid, aeadid, conf) crO mpskExt = E.handle hpkeHandler $ do+ let (chExtsO, chExtsI) = dupCompExts (cnfPublicName conf) mpskExt chExtensions+ chI =+ ch0+ { chSession = Session Nothing+ , chExtensions = chExtsI+ }+ Just (func, enc, taglen) <- getHPKE ctx echParams+ let bsI = encodeHandshake' $ ClientHello chI+ padLen = 32 - (B.length bsI .&. 31)+ bsI' = bsI <> B.replicate padLen 0+ let outerZ =+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfConfigId conf+ , echEnc = enc+ , echPayload = B.replicate (B.length bsI' + taglen) 0+ }+ echOZ = extensionEncode outerZ+ chExtsOTail = drop 1 chExtsO+ chOZ =+ ch0+ { chRandom = crO+ , chExtensions =+ ExtensionRaw EID_EncryptedClientHello echOZ : chExtsOTail+ }+ aad = encodeHandshake' $ ClientHello chOZ+ bsO <- func aad bsI'+ let outer =+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfConfigId conf+ , echEnc = enc+ , echPayload = bsO+ }+ echO = extensionEncode outer+ chO =+ chOZ+ { chExtensions =+ ExtensionRaw EID_EncryptedClientHello echO : chExtsOTail+ }+ return chO+ where+ hpkeHandler :: HPKEError -> IO ClientHello+ hpkeHandler _ = return ch0++dupCompExts+ :: HostName+ -> Maybe ExtensionRaw+ -> [ExtensionRaw]+ -> ([ExtensionRaw], [ExtensionRaw]) -- Outer, inner+dupCompExts host mpskExt chExts = step1 chExts+ where+ step1 (echExtI@(ExtensionRaw EID_EncryptedClientHello _) : exts) =+ (echExtO : os, echExtI : is)+ where+ echExtO = ExtensionRaw EID_EncryptedClientHello ""+ (os, is) = step2 exts+ step1 _ = error "step1"+ step2 (sniExtI@(ExtensionRaw EID_ServerName _) : exts) =+ (sniExtO : os, sniExtI : is)+ where+ (os, is) = step3 exts id+ -- 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 []+ step3 [pskExtI@(ExtensionRaw EID_PreSharedKey _)] build =+ ([pskExtO], [echOuterExt, pskExtI])+ where+ echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []+ pskExtO = fromJust mpskExt+ step3 (i@(ExtensionRaw eid _) : is) build = (i : os', is')+ where+ (os', is') = step3 is (build . (eid :))++getHPKE+ :: Context+ -> (KDF_ID, AEAD_ID, ECHConfig)+ -> IO (Maybe (AAD -> PlainText -> IO CipherText, EncodedPublicKey, Int))+getHPKE ctx (kdfid, aeadid, conf) = do+ mfunc <- getTLS13HPKE ctx+ case mfunc of+ Nothing -> do+ let encodedConfig = encodeECHConfig conf+ info = "tls ech\x00" <> encodedConfig+ (pkSm, ctxS) <- setupBaseS kemid kdfid aeadid Nothing Nothing mpkR info+ let func = seal ctxS+ setTLS13HPKE ctx func 0+ return $ Just (func, pkSm, nT)+ Just (func, _) -> return $ Just (func, EncodedPublicKey "", nT)+ where+ mpkR = cnfEncodedPublicKey conf+ kemid = cnfKemId conf+ nT = nTag aeadid++----------------------------------------------------------------++lookupECHConfigList+ :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -> ECHConfigList+ -> Maybe (KDF_ID, AEAD_ID, ECHConfig)+lookupECHConfigList [] _ = Nothing+lookupECHConfigList ((kemid, kdfid, aeadid) : xs) cnfs =+ case find (\cnf -> cnfKemId cnf == kemid) cnfs of+ Nothing -> lookupECHConfigList xs cnfs+ Just cnf+ | (kdfid, aeadid) `elem` cnfCipherSuite cnf ->+ Just (kdfid, aeadid, cnf)+ | otherwise -> lookupECHConfigList xs cnfs++cnfKemId :: ECHConfig -> KEM_ID+cnfKemId ECHConfig{..} = KEM_ID $ kem_id $ key_config contents++cnfCipherSuite :: ECHConfig -> [(KDF_ID, AEAD_ID)]+cnfCipherSuite ECHConfig{..} = map conv $ cipher_suites $ key_config contents+ where+ conv HpkeSymmetricCipherSuite{..} = (KDF_ID kdf_id, AEAD_ID aead_id)++cnfEncodedPublicKey :: ECHConfig -> EncodedPublicKey+cnfEncodedPublicKey ECHConfig{..} = EncodedPublicKey pk+ where+ EncodedServerPublicKey pk = public_key $ key_config contents++cnfPublicName :: ECHConfig -> HostName+cnfPublicName ECHConfig{..} = public_name contents++cnfConfigId :: ECHConfig -> ConfigId+cnfConfigId ECHConfig{..} = config_id $ key_config contents++----------------------------------------------------------------++-- Pretending X25519 is used because it is the de-facto and+-- its public key is easily created.+greasingEchExt :: IO ExtensionRaw+greasingEchExt = do+ cid <- getStdRandom genWord8+ enc <- getStdRandom $ uniformByteString 32+ n <- getStdRandom $ randomR (4, 6)+ payload <- getStdRandom $ uniformByteString (n * 32 + 16)+ let outer =+ ECHClientHelloOuter+ { echCipherSuite = (HKDF_SHA256, AES_128_GCM)+ , echConfigId = cid+ , echEnc = EncodedPublicKey enc+ , echPayload = payload+ }+ return $ toExtensionRaw outer++#if !MIN_VERSION_random(1,3,0)+uniformByteString :: RandomGen g => Int -> g -> (ByteString, g)+uniformByteString l g0 = (bs, g2)+ where+ (g1, g2) = split g0+ bs = unsafeCreate l $ go 0 g1+ go n g ptr+ | n == l = return ()+ | otherwise = do+ let (w, g') = genWord8 g+ poke ptr w+ go (n + 1) g' (plusPtr ptr 1)+#endif
Network/TLS/Handshake/Client/Common.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.Common ( throwMiscErrorOnException,@@ -9,11 +10,13 @@ sigAlgsToCertTypes, setALPN, contextSync,+ 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@@ -36,7 +39,7 @@ ---------------------------------------------------------------- -throwMiscErrorOnException :: String -> SomeException -> IO a+throwMiscErrorOnException :: String -> E.SomeException -> IO a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e @@ -122,7 +125,9 @@ -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of- CertificateUsageAccept -> checkLeafCertificateKeyUsage+ CertificateUsageAccept -> do+ verifyLeafKeyUsagePurpose KeyUsagePurpose_ServerAuth certs+ checkLeafCertificateKeyUsage CertificateUsageReject reason -> certificateRejected reason where shared = clientShared cparams@@ -332,19 +337,44 @@ ---------------------------------------------------------------- setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()-setALPN ctx msgt exts = case extensionLookup EID_ApplicationLayerProtocolNegotiation exts- >>= extensionDecode msgt of- Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do- mprotos <- getClientALPNSuggest+setALPN ctx msgt exts =+ lookupAndDecodeAndDo+ EID_ApplicationLayerProtocolNegotiation+ msgt+ exts+ (return ())+ setAlpn+ where+ setAlpn (ApplicationLayerProtocolNegotiation [proto]) = do+ mprotos <- usingState_ ctx getClientALPNSuggest case mprotos of- Just protos -> when (proto `elem` protos) $ do- setExtensionALPN True- setNegotiatedProtocol proto- _ -> return ()- _ -> 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 ---------------------------------------------------------------- contextSync :: Context -> ClientState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync sync _ -> sync ctx ctl++clientSessions :: ClientParams -> [(SessionID, SessionData)]+clientSessions ClientParams{..} = case clientWantSessionResume of+ Nothing -> clientWantSessionResumeList+ Just ent -> clientWantSessionResumeList ++ [ent]
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.ServerHello (- recvServerHello,+ receiveServerHello, processServerHello13, ) where +import Data.ByteArray (convert)+import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -12,13 +16,14 @@ import Network.TLS.Extension import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -27,13 +32,27 @@ ---------------------------------------------------------------- -recvServerHello- :: ClientParams -> Context -> IO [Handshake]-recvServerHello cparams ctx = do- (sh, hss) <- recvSH+receiveServerHello+ :: ClientParams+ -> Context+ -> Maybe (ClientRandom, Session, Version)+ -> IO (Version, [HandshakeR], Bool)+receiveServerHello cparams ctx mparams = do+ chSentTime <- getCurrentTimeFromBase+ (shb@(sh, _), hbs) <- recvSH processServerHello cparams ctx sh- processHandshake12 ctx sh- return hss+ updateTranscriptHash12 ctx shb+ setRTT ctx chSentTime+ ver <- usingState_ ctx getVersion+ unless (maybe True (\(_, _, v) -> v == ver) mparams) $+ throwCore $+ Error_Protocol "version changed after hello retry" IllegalParameter+ -- recvServerHello sets TLS13HRR according to the server random.+ -- For 1st server hello, getTLS13HR returns True if it is HRR and+ -- False otherwise. For 2nd server hello, getTLS13HR returns+ -- False since it is NOT HRR.+ hrr <- usingState_ ctx getTLS13HRR+ return (ver, hbs, hrr) where recvSH = do epkt <- recvPacket12 ctx@@ -41,7 +60,7 @@ Left e -> throwCore e Right pkt -> case pkt of Alert a -> throwAlert a- Handshake (h : hs) -> return (h, hs)+ Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs) _ -> unexpected (show pkt) (Just "handshake") throwAlert a = throwCore $@@ -53,71 +72,86 @@ processServerHello13 :: ClientParams -> Context -> Handshake13 -> IO ()-processServerHello13 cparams ctx (ServerHello13 serverRan serverSession cipher exts) = do- let sh = ServerHello TLS12 serverRan serverSession cipher 0 exts- processServerHello cparams ctx sh+processServerHello13 cparams ctx (ServerHello13 sh13) = do+ let sh12 = ServerHello sh13+ processServerHello cparams ctx sh12 processServerHello13 _ _ h = unexpected (show h) (Just "server hello") -- | processServerHello processes the ServerHello message on the client. ----- 1) check the version chosen by the server is one allowed by parameters.--- 2) check that our compression and cipher algorithms are part of the list we sent+-- 1) check the version chosen by the server is one allowed by+-- parameters.+-- 2) check that our compression and cipher algorithms are part of the+-- list we sent -- 3) check extensions received are part of the one we sent--- 4) process the session parameter to see if the server want to start a new session or can resume+-- 4) process the session parameter to see if the server want to start+-- a new session or can resume processServerHello :: ClientParams -> Context -> Handshake -> IO ()-processServerHello cparams ctx (ServerHello rver serverRan serverSession cipher compression exts) = do+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.- when (rver /= TLS12) $+ when (shVersion /= TLS12) $ throwCore $- Error_Protocol (show rver ++ " is not supported") IllegalParameter+ Error_Protocol (show shVersion ++ " is not supported") IllegalParameter -- find the compression and cipher methods that the server want to use. clientSession <- tls13stSession <$> getTLS13State ctx- sentExts <- tls13stSentExtensions <$> getTLS13State ctx- cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of+ chExts <- tls13stSentExtensions <$> getTLS13State ctx+ let clientCiphers = supportedCiphers $ ctxSupported ctx+ usedCipher <- case findCipher (fromCipherId shCipher) clientCiphers of Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter Just alg -> return alg compressAlg <- case find- ((==) compression . compressionID)+ ((==) shComp . compressionID) (supportedCompressions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter Just alg -> return alg- ensureNullCompression compression+ ensureNullCompression shComp - -- intersect sent extensions in client and the received extensions from server.- -- if server returns extensions that we didn't request, fail.+ -- intersect sent extensions in client and the received extensions+ -- from server. if server returns extensions that we didn't+ -- request, fail. let checkExt (ExtensionRaw i _) | i == EID_Cookie = False -- for HRR- | otherwise = i `notElem` sentExts- when (any checkExt exts) $+ | otherwise = i `notElem` chExts+ when (any checkExt shExtensions) $ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension - let isHRR = isHelloRetryRequest serverRan+ let isHRR = isHelloRetryRequest shRandom usingState_ ctx $ do setTLS13HRR isHRR- setTLS13Cookie- ( guard isHRR- >> extensionLookup EID_Cookie exts- >>= extensionDecode MsgTServerHello- )- setVersion rver -- must be before processing supportedVersions ext- mapM_ processServerExtension exts+ when isHRR $+ setTLS13Cookie $+ lookupAndDecode+ EID_Cookie+ MsgTServerHello+ shExtensions+ Nothing+ (\cookie@(Cookie _) -> Just cookie)+ setVersion shVersion -- must be before processing supportedVersions ext+ mapM_ processServerExtension shExtensions - setALPN ctx MsgTServerHello exts+ setALPN ctx MsgTServerHello shExtensions ver <- usingState_ ctx getVersion - when (ver == TLS12) $ do- usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg+ 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- when (clientSession /= serverSession) $+ -- TLS 1.3 server MUST echo the session id+ when (clientSession /= shSession) $ throwCore $ Error_Protocol "session is not matched in compatibility mode"@@ -128,28 +162,48 @@ ("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 the TLS 1.2- -- downgrade signal in the server random. If we support TLS 1.3 and- -- actually negotiate TLS 1.3, we must ignore the server random downgrade- -- signal. Therefore, 'isDowngraded' needs to take into account the- -- negotiated version and the server random, as well as the list of- -- client-side enabled protocol versions.+ -- Some servers set TLS 1.2 as the legacy server hello version,+ -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set+ -- the TLS 1.2 downgrade signal in the server random. If we+ -- support TLS 1.3 and actually negotiate TLS 1.3, we must ignore+ -- the server random downgrade signal. Therefore, 'isDowngraded'+ -- needs to take into account the negotiated version and the+ -- server random, as well as the list of client-side enabled+ -- protocol versions. --- when (isDowngraded ver supportedVers serverRan) $+ when (isDowngraded ver supportedVers shRandom) $ throwCore $ Error_Protocol "version downgrade detected" IllegalParameter - let resumingSession =- case clientWantSessionResume cparams of- Just (_, sessionData) ->- if serverSession == clientSession then Just sessionData else Nothing- Nothing -> Nothing- usingState_ ctx $ setSession serverSession (isJust resumingSession)- if ver == TLS13- then updateContext13 ctx cipherAlg- else updateContext12 ctx exts resumingSession+ then do+ -- Session is dummy in TLS 1.3.+ usingState_ ctx $ setSession shSession+ processRecordSizeLimit ctx shExtensions True+ enableMyRecordLimit ctx+ enablePeerRecordLimit ctx+ let usedHash = cipherHash usedCipher+ transitTranscriptHashI ctx "transitI" usedHash isHRR+ accepted <- checkECHacceptance ctx isHRR usedHash sh+ when accepted $ do+ (CH{..}, _b) <- fromJust <$> usingHState ctx getClientHello+ usingHState ctx $ setClientRandom chRandom -- inner random+ when (accepted && not isHRR) $ do+ copyTranscriptHash ctx "copy"+ usingHState ctx $ setECHAccepted True+ updateContext13 ctx usedCipher isHRR+ updateTranscriptHashI ctx "ServerHelloI" $ encodeHandshake $ ServerHello sh+ else do+ let resumingSession = case clientSessions cparams of+ (_, sessionData) : _ ->+ if shSession == clientSession then Just sessionData else Nothing+ _ -> Nothing++ usingState_ ctx $ do+ setSession shSession+ setTLS12SessionResuming $ isJust resumingSession+ processRecordSizeLimit ctx shExtensions False+ updateContext12 ctx shExtensions resumingSession processServerHello _ _ p = unexpected (show p) (Just "server hello") ----------------------------------------------------------------@@ -157,8 +211,8 @@ processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw extID content) | extID == EID_SecureRenegotiation = do- cvd <- getVerifyData ClientRole- svd <- getVerifyData ServerRole+ VerifyData cvd <- getVerifyData ClientRole+ VerifyData svd <- getVerifyData ServerRole let bs = extensionEncode $ SecureRenegotiation cvd svd unless (bs == content) $ throwError $@@ -177,8 +231,8 @@ ---------------------------------------------------------------- -updateContext13 :: Context -> Cipher -> IO ()-updateContext13 ctx cipherAlg = do+updateContext13 :: Context -> Cipher -> Bool -> IO ()+updateContext13 ctx usedCipher isHRR = do established <- ctxEstablished ctx eof <- ctxEOF ctx when (established == Established && not eof) $@@ -186,11 +240,11 @@ Error_Protocol "renegotiation to TLS 1.3 or later is not allowed" ProtocolVersion- failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher isHRR updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()-updateContext12 ctx exts resumingSession = do- ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello exts+updateContext12 ctx shExtensions resumingSession = do+ ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExtensions case resumingSession of Nothing -> return () Just sessionData -> do@@ -198,6 +252,61 @@ when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent" in throwCore $ Error_Protocol err HandshakeFailure- let mainSecret = sessionSecret sessionData+ let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret logKey ctx (MainSecret mainSecret)++----------------------------------------------------------------++processRecordSizeLimit+ :: Context -> [ExtensionRaw] -> Bool -> IO ()+processRecordSizeLimit ctx shExtensions tls13 = do+ let mmylim = limitRecordSize $ sharedLimit $ ctxShared ctx+ case mmylim of+ Nothing -> return ()+ Just mylim -> do+ lookupAndDecodeAndDo+ EID_RecordSizeLimit+ MsgTClientHello+ shExtensions+ (return ())+ (setPeerRecordSizeLimit ctx tls13)+ ack <- checkPeerRecordLimit ctx+ -- When a client sends RecordSizeLimit, it does not know+ -- which TLS version the server selects. RecordLimit is+ -- the length of plaintext. But RecordSizeLimit also+ -- includes CT: and padding for TLS 1.3. To convert+ -- RecordSizeLimit to RecordLimit, we should reduce the+ -- value by 1, which is the length of CT:.+ when (ack && tls13) $ setMyRecordLimit ctx $ Just (mylim - 1)++----------------------------------------------------------------++checkECHacceptance :: Context -> Bool -> Hash -> ServerHello -> IO Bool+checkECHacceptance ctx False usedHash sh@SH{..} = do+ let (prefix, confirm) = B.splitAt 24 $ unServerRandom shRandom+ sr' = ServerRandom (prefix <> "\x00\x00\x00\x00\x00\x00\x00\x00")+ verified <-+ computeConfirm ctx usedHash sh{shRandom = sr'} "ech accept confirmation"+ return (confirm == verified)+checkECHacceptance ctx True usedHash sh@SH{..} = do+ case replace shExtensions of+ Nothing -> return False+ Just (confirm, shExts') -> do+ verified <-+ computeConfirm+ ctx+ usedHash+ sh{shExtensions = shExts'}+ "hrr ech accept confirmation"+ return (confirm == verified)+ where+ replace [] = Nothing+ replace (ExtensionRaw EID_EncryptedClientHello confirm : es) =+ Just+ ( confirm+ , ExtensionRaw EID_EncryptedClientHello "\x00\x00\x00\x00\x00\x00\x00\x00" : es+ )+ replace (e : es) = case replace es of+ Nothing -> Nothing+ Just (confirm, es') -> Just (confirm, e : es')
Network/TLS/Handshake/Client/TLS12.hs view
@@ -8,6 +8,7 @@ ) where import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -32,17 +33,18 @@ ---------------------------------------------------------------- -recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()-recvServerFirstFlight12 cparams ctx hs = do- resuming <- usingState_ ctx isSessionResuming+recvServerFirstFlight12+ :: ClientParams -> Context -> [HandshakeR] -> IO ()+recvServerFirstFlight12 cparams ctx hbs = do+ resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do let st = RecvStateHandshake (expectCertificate cparams ctx)- runRecvStateHS ctx st hs+ runRecvStateHS ctx st hbs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)-expectCertificate cparams ctx (Certificate certs) = do+expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do usingState_ ctx $ setServerCertificateChain certs doCertificate cparams ctx certs processCertificate ctx ClientRole certs@@ -72,32 +74,35 @@ sendClientSecondFlight12 :: ClientParams -> Context -> IO () sendClientSecondFlight12 cparams ctx = do- sessionResuming <- usingState_ ctx isSessionResuming+ sessionResuming <- usingState_ ctx getTLS12SessionResuming if sessionResuming then sendCCSandFinished ctx ClientRole else do sendClientCCC cparams ctx sendCCSandFinished ctx ClientRole -recvServerSecondFlight12 :: Context -> IO ()-recvServerSecondFlight12 ctx = do- sessionResuming <- usingState_ ctx isSessionResuming+recvServerSecondFlight12 :: ClientParams -> Context -> IO ()+recvServerSecondFlight12 cparams ctx = do+ sessionResuming <- usingState_ ctx getTLS12SessionResuming unless sessionResuming $ recvNSTandCCSandFinished ctx mticket <- usingState_ ctx getTLS12SessionTicket- identity <- case mticket of- Just ticket -> return ticket- Nothing -> do- session <- usingState_ ctx getSession- case session of- Session (Just sessionId) -> return $ B.copy sessionId- _ -> return "" -- never reach- sessionData <- getSessionData ctx- void $- sessionEstablish- (sharedSessionManager $ ctxShared ctx)- identity- (fromJust sessionData)- handshakeDone12 ctx+ session <- usingState_ ctx getSession+ let midentity = ticketOrSessionID12 mticket session+ case midentity of+ Nothing -> return ()+ Just identity -> do+ sessionData <- getSessionData ctx+ void $+ sessionEstablish+ (sharedSessionManager $ ctxShared ctx)+ identity+ (fromJust sessionData)+ finishHandshake12 ctx+ liftIO $ do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> return ()+ Just info -> onServerFinished (clientHooks cparams) info recvNSTandCCSandFinished :: Context -> IO () recvNSTandCCSandFinished ctx = do@@ -112,6 +117,7 @@ expectNewSessionTicket p = unexpected (show p) (Just "Handshake Finished") expectChangeCipher ChangeCipherSpec = do+ enableMyRecordLimit ctx return $ RecvStateHandshake $ expectFinished ctx expectChangeCipher p = unexpected (show p) (Just "change cipher") @@ -147,7 +153,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True- sendPacket12 ctx $ Handshake [Certificate cc]+ sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] [] ---------------------------------------------------------------- @@ -163,19 +169,19 @@ _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure- sendPacket12 ctx $ Handshake [ClientKeyXchg ckx]+ sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] [] mainSecret <- usingHState ctx setMainSec logKey ctx (MainSecret mainSecret) -------------------------------- getCKX_RSA- :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_RSA ctx = do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 - let preMain = encodePreMainSecret clientVersion prerand+ let preMain = convert $ encodePreMainSecret clientVersion prerand setMainSec = setMainSecretFromPre xver ClientRole preMain encryptedPreMain <- do -- SSL3 implementation generally forget this length field since it's redundant,@@ -190,7 +196,7 @@ getCKX_DHE :: ClientParams -> Context- -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_DHE cparams ctx = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams@@ -237,12 +243,12 @@ -------------------------------- getCKX_ECDHE- :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_ECDHE ctx = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setSupportedGroup grp- ecdhePair <- generateECDHEShared ctx srvpub+ ecdhePair <- encapsulateGroup ctx srvpub case ecdhePair of Nothing -> throwCore $@@ -250,7 +256,7 @@ Just (clipub, preMain) -> do xver <- usingState_ ctx getVersion let setMainSec = setMainSecretFromPre xver ClientRole preMain- return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec)+ return (CKX_ECDH $ groupEncodePublicB clipub, setMainSec) ---------------------------------------------------------------- @@ -279,4 +285,4 @@ -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs- sendPacket12 ctx $ Handshake [CertVerify sigDig]+ sendPacket12 ctx $ Handshake [CertVerify sigDig] []
Network/TLS/Handshake/Client/TLS13.hs view
@@ -7,14 +7,15 @@ postHandshakeAuthClientWith, ) where -import Control.Exception (bracket)+import qualified Control.Exception as E import Control.Monad.State.Strict-import qualified Data.ByteString as B+import qualified Data.ByteArray as BA import Data.IORef import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto+import Network.TLS.Error import Network.TLS.Extension import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Client.ServerHello@@ -22,10 +23,10 @@ import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Control import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters@@ -38,25 +39,25 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -recvServerSecondFlight13 :: ClientParams -> Context -> Maybe Group -> IO ()+recvServerSecondFlight13 :: ClientParams -> Context -> [Group] -> IO () recvServerSecondFlight13 cparams ctx groupSent = do resuming <- prepareSecondFlight13 ctx groupSent runRecvHandshake13 $ do recvHandshake13 ctx $ expectEncryptedExtensions ctx unless resuming $ recvHandshake13 ctx $ expectCertRequest cparams ctx- recvHandshake13hash ctx $ expectFinished ctx+ recvHandshake13hash ctx "Finished" $ expectFinished cparams ctx ---------------------------------------------------------------- prepareSecondFlight13- :: Context -> Maybe Group -> IO Bool+ :: Context -> [Group] -> IO Bool prepareSecondFlight13 ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher prepareSecondFlight13' ctx groupSent choice prepareSecondFlight13' :: Context- -> Maybe Group+ -> [Group] -> CipherChoice -> IO Bool prepareSecondFlight13' ctx groupSent choice = do@@ -99,10 +100,10 @@ "key exchange not implemented, expected key_share extension" HandshakeFailure let grp = keyShareEntryGroup serverKeyShare- unless (checkKeyShareKeyLength serverKeyShare) $+ unless (checkServerKeyShareKeyLength serverKeyShare) $ throwCore $ Error_Protocol "broken key_share" IllegalParameter- unless (groupSent == Just grp) $+ unless (grp `elem` groupSent) $ throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter usingHState ctx $ setSupportedGroup grp@@ -118,7 +119,7 @@ Nothing -> return (initEarlySecret choice Nothing, False) Just (PreSharedKeyServerHello 0) -> do- unless (B.length sec == hashSize) $+ unless (BA.length sec == hashSize) $ throwCore $ Error_Protocol "selected cipher is incompatible with selected PSK"@@ -146,12 +147,13 @@ Nothing -> do usingHState ctx $ setTLS13HandshakeMode PreSharedKey usingHState ctx $ setTLS13RTT0Status RTT0Rejected-expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions")+expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ---------------------------------------------------------------- -- not used in 0-RTT expectCertRequest- :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertRequest cparams ctx (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx $ expectCertAndVerify cparams ctx@@ -177,15 +179,21 @@ Nothing -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure -- Unused: -- caAlgs <- extalgs caextID uncertsig+ let zlib =+ lookupAndDecode+ EID_CompressCertificate+ MsgTClientHello+ exts+ False+ (\(CompressCertificate ccas) -> CCA_Zlib `elem` ccas) usingHState ctx $ do setCertReqToken $ Just token setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)+ setTLS13CertComp zlib where -- setCertReqSigAlgsCert caAlgs - canames = case extensionLookup- EID_CertificateAuthorities- exts of+ canames = case extensionLookup EID_CertificateAuthorities exts of Nothing -> return [] Just ext -> case extensionDecode MsgTCertificateRequest ext of Just (CertificateAuthorities names) -> return names@@ -204,41 +212,55 @@ ---------------------------------------------------------------- -- not used in 0-RTT expectCertAndVerify- :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()-expectCertAndVerify cparams ctx (Certificate13 _ cc _) = do+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify _ _ h = unexpected (show h) (Just "server certificate")++processCertAndVerify+ :: MonadIO m+ => ClientParams -> Context -> CertificateChain -> RecvHandshake13M m ()+processCertAndVerify 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 $ expectCertVerify ctx pubkey-expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate")+ recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey ---------------------------------------------------------------- expectCertVerify- :: MonadIO m => Context -> PubKey -> ByteString -> Handshake13 -> m ()-expectCertVerify ctx pubkey hChSc (CertVerify13 sigAlg sig) = do+ :: MonadIO m+ => Context -> PubKey -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify ctx pubkey (TranscriptHash hChSc) (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify"-expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify")+expectCertVerify _ _ _ h = unexpected (show h) (Just "certificate verify") ---------------------------------------------------------------- expectFinished :: MonadIO m- => Context- -> ByteString+ => ClientParams+ -> Context+ -> TranscriptHash -> Handshake13 -> m ()-expectFinished ctx hashValue (Finished13 verifyData) = do+expectFinished cparams ctx hashValue (Finished13 verifyData) = do st <- liftIO $ getTLS13State ctx let usedHash = cHash $ tls13stChoice st ServerTrafficSecret baseKey = triServer $ fromJust $ tls13stHsKey st checkFinished ctx usedHash baseKey hashValue verifyData+ liftIO $ do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> return ()+ Just info -> onServerFinished (clientHooks cparams) info liftIO $ modifyTLS13State ctx $ \s -> s{tls13stRecvSF = True}-expectFinished _ _ p = unexpected (show p) (Just "server finished")+expectFinished _ _ _ p = unexpected (show p) (Just "server finished") ---------------------------------------------------------------- ----------------------------------------------------------------@@ -252,6 +274,10 @@ eexts = tls13stClientExtensions st sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts modifyTLS13State ctx $ \s -> s{tls13stSentCF = True}+ echAccepted <- usingHState ctx getECHAccepted+ when (clientUseECH cparams && not echAccepted) $+ throwCore $+ Error_Protocol "ECH is not accepted" EchRequired sendClientSecondFlight13' :: ClientParams@@ -262,12 +288,12 @@ -> [ExtensionRaw] -> IO () sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts = do- hChSf <- transcriptHash ctx+ hChSf <- transcriptHash ctx "CH..SF" unless (ctxQUICMode ctx) $ runPacketFlight ctx $ sendChangeCipherSpec13 ctx when (rtt0accepted && not (ctxQUICMode ctx)) $- sendPacket13 ctx (Handshake13 [EndOfEarlyData13])+ sendPacket13 ctx (Handshake13 [EndOfEarlyData13] []) let clientHandshakeSecret = triClient hkey setTxRecordState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret@@ -277,7 +303,7 @@ let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey) contextSync ctx $ SendClientFinished eexts appSecInfo modifyTLS13State ctx $ \st -> st{tls13stHsKey = Nothing}- handshakeDone13 ctx+ finishHandshake13 ctx rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ do builder <- tls13stPendingSentData <$> getTLS13State ctx@@ -316,39 +342,48 @@ runPacketFlight ctx $ do case mcc of Nothing -> return ()- Just cc -> usingHState ctx getCertReqToken >>= loadClientData13 cc+ Just cc -> do+ reqtoken <- usingHState ctx getCertReqToken+ certComp <- usingHState ctx getTLS13CertComp+ loadClientData13 cc reqtoken certComp rawFinished <- makeFinished ctx usedHash baseKey- loadPacket13 ctx $ Handshake13 [rawFinished]+ loadPacket13 ctx $ Handshake13 [rawFinished] [] when (isJust mcc) $ modifyTLS13State ctx $ \st -> st{tls13stSentClientCert = True} where- loadClientData13 chain (Just token) = do+ loadClientData13 chain (Just token) certComp = do let (CertificateChain certs) = chain certExts = replicate (length certs) [] cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx- loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]+ let certtag = if certComp then CompressedCertificate13 else Certificate13+ loadPacket13 ctx $+ Handshake13 [certtag token (CertificateChain_ chain) certExts] [] case certs of [] -> return () _ -> do- hChSc <- transcriptHash ctx+ hChSc <- transcriptHash ctx "CH..SC" pubKey <- getLocalPublicKey ctx sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc- loadPacket13 ctx $ Handshake13 [vfy]+ loadPacket13 ctx $ Handshake13 [vfy] [] --- loadClientData13 _ _ =+ loadClientData13 _ _ _ = throwCore $ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError ---------------------------------------------------------------- ---------------------------------------------------------------- -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- processHandshake13 ctx h+postHandshakeAuthClientWith+ :: ClientParams -> Context -> Handshake13R -> IO ()+postHandshakeAuthClientWith cparams ctx hb@(CertRequest13 certReqCtx exts, _) =+ E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ -- RFC 8446 Section 4.4: the handshake context of+ -- post-handshake authentication is ClientHello ... client+ -- Finished + CertificateRequest.+ updateTranscriptHash13 ctx hb processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $@@ -356,7 +391,11 @@ Error_Protocol "unexpected post-handshake authentication request" UnexpectedMessage- sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN)+ sendClientFlight13+ cparams+ ctx+ usedHash+ (ClientTrafficSecret applicationSecretN) postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol@@ -367,25 +406,22 @@ ---------------------------------------------------------------- asyncServerHello13- :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO ()+ :: ClientParams -> Context -> [Group] -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx- [ PendingRecvAction True expectServerHello- , PendingRecvAction- True- (expectEncryptedExtensions ctx)- , PendingRecvActionHash- True- expectFinishedAndSet+ [ PendingRecvActionSelfUpdate True expectServerHello+ , PendingRecvAction True (expectEncryptedExtensions ctx)+ , PendingRecvActionHash True expectFinishedAndSet ] where- expectServerHello sh = do+ expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh+ updateTranscriptHash13 ctx shb -- update by myself void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do- expectFinished ctx h sf+ expectFinished cparams ctx h sf liftIO $ writeIORef (ctxPendingSendAction ctx) $ Just $
Network/TLS/Handshake/Common.hs view
@@ -6,8 +6,8 @@ handleException, unexpected, newSession,- handshakeDone12, ensureNullCompression,+ ticketOrSessionID12, -- * sending packets sendCCSandFinished,@@ -20,7 +20,6 @@ onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret,- extensionLookup, getSessionData, storePrivInfo, isSupportedGroup,@@ -29,11 +28,22 @@ errorToAlertMessage, expectFinished, processCertificate,+ --+ setPeerRecordSizeLimit,+ generateFinished,+ encodeUpdateTranscriptHash12,+ updateTranscriptHash12,+ --+ startHandshake,+ finishHandshake12,+ setServerHelloParameters12, ) 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 Network.TLS.Cipher import Network.TLS.Compression@@ -41,13 +51,15 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Measurement+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -57,28 +69,31 @@ 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+ debugError (ctxDebug ctx) $ show exception -- 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 when (established == EarlyDataSending) $ clearTxRecordState ctx- sendPacket13 ctx $ Alert13 [errorToAlert tlserror]+ when (tlserror /= Error_TCP_Terminate) $+ sendPacket13 ctx $+ Alert13 [errorToAlert tlserror] else sendPacket12 ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where- ignoreIOErr :: IOException -> IO ()+ ignoreIOErr :: E.IOException -> IO () ignoreIOErr _ = return () errorToAlert :: TLSError -> (AlertLevel, AlertDescription)@@ -88,6 +103,9 @@ 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)+ | "unsupported certificate compression algorithm" `isInfixOf` msg =+ (AlertLevel_Fatal, IllegalParameter) | otherwise = (AlertLevel_Fatal, DecodeError) errorToAlert _ = (AlertLevel_Fatal, InternalError) @@ -109,26 +127,6 @@ | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 | otherwise = return $ Session Nothing --- | when a new handshake is done, wrap up & clean up.-handshakeDone12 :: Context -> IO ()-handshakeDone12 ctx = do- -- forget most handshake data and reset bytes counters.- modifyMVar_ (ctxHandshakeState ctx) $ \case- Nothing -> return Nothing- Just hshake ->- return $- Just- (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMainSecret = hstMainSecret hshake- , hstExtendedMainSecret = hstExtendedMainSecret hshake- , hstSupportedGroup = hstSupportedGroup hshake- }- updateMeasure ctx resetBytesCounters- -- mark the secure connection up and running.- setEstablished ctx Established- return ()- sendCCSandFinished :: Context -> Role@@ -136,9 +134,10 @@ sendCCSandFinished ctx role = do sendPacket12 ctx ChangeCipherSpec contextFlush ctx- verifyData <-- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role- sendPacket12 ctx (Handshake [Finished verifyData])+ enablePeerRecordLimit ctx+ ver <- usingState_ ctx getVersion+ verifyData <- VerifyData <$> generateFinished ctx ver role+ sendPacket12 ctx (Handshake [Finished verifyData] []) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx @@ -147,11 +146,11 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake]+recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do pkts <- recvPacket12 ctx case pkts of- Right (Handshake l) -> return l+ Right (Handshake hss bss) -> return $ zip hss bss Right x@(AppData _) -> do -- If a TLS13 server decides to reject RTT0 data, the server should -- skip records for RTT0 data up to the maximum limit.@@ -167,16 +166,18 @@ -- | process a list of handshakes message in the recv state machine. onRecvStateHandshake- :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)+ :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO) onRecvStateHandshake _ recvState [] = return recvState-onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms)-onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do- let finished = isFinished x- unless finished $ processHandshake12 ctx x- nstate <- f x- when finished $ processHandshake12 ctx x- onRecvStateHandshake ctx nstate xs-onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing+onRecvStateHandshake _ (RecvStatePacket f) hbs = do+ let (hss, bss) = unzip hbs+ f (Handshake hss bss)+onRecvStateHandshake ctx (RecvStateHandshake f) (hb@(h, _) : hbs) = do+ let finished = isFinished h+ unless finished $ void $ updateTranscriptHash12 ctx hb+ nstate <- f h+ when finished $ void $ updateTranscriptHash12 ctx hb+ onRecvStateHandshake ctx nstate hbs+onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing isFinished :: Handshake -> Bool isFinished Finished{} = True@@ -190,8 +191,9 @@ >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx -runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()-runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx+runRecvStateHS+ :: Context -> RecvState IO -> [HandshakeR] -> IO ()+runRecvStateHS ctx iniState hbs = onRecvStateHandshake ctx iniState hbs >>= runRecvState ctx ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do@@ -207,14 +209,23 @@ | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" | ems == NoEMS = return False | otherwise =- case extensionLookup EID_ExtendedMainSecret exts >>= extensionDecode msgt of- Just ExtendedMainSecret -> usingHState ctx (setExtendedMainSecret True) >> return True- Nothing- | ems == RequireEMS -> throwCore $ Error_Protocol err HandshakeFailure- | otherwise -> return False+ liftIO $+ lookupAndDecodeAndDo+ EID_ExtendedMainSecret+ msgt+ exts+ nonExistAction+ existAction where- ems = supportedExtendedMainSecret (ctxSupported ctx)+ ems = supportedExtendedMainSecret $ ctxSupported ctx err = "peer does not support Extended Main Secret"+ nonExistAction =+ if ems == RequireEMS+ then throwCore $ Error_Protocol err HandshakeFailure+ else return False+ existAction ExtendedMainSecret = do+ usingHState ctx $ setExtendedMainSecret True+ return True getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do@@ -236,7 +247,7 @@ , sessionCipher = cipher , sessionCompression = compression , sessionClientSNI = sni- , sessionSecret = ms+ , sessionSecret = convert ms , sessionGroup = Nothing , sessionTicketInfo = Nothing , sessionALPN = alpn@@ -244,11 +255,6 @@ , sessionFlags = flags } -extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString-extensionLookup toFind =- fmap (\(ExtensionRaw _ content) -> content)- . find (\(ExtensionRaw eid _) -> eid == toFind)- -- | Store the specified keypair. Whether the public key and private key -- actually match is left for the peer to discover. We're not presently -- burning CPU to detect that misconfiguration. We verify only that the@@ -298,8 +304,8 @@ processFinished :: Context -> VerifyData -> IO () processFinished ctx verifyData = do (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion- expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc- when (expected /= verifyData) $ decryptError "cannot verify finished"+ expected <- VerifyData <$> generateFinished ctx ver (invertRole cc)+ when (expected /= verifyData) $ decryptError "finished verification failed" usingState_ ctx $ setVerifyDataForRecv verifyData processCertificate :: Context -> Role -> CertificateChain -> IO ()@@ -310,3 +316,130 @@ usingHState ctx $ setPublicKey pubkey where pubkey = certPubKey $ getCertificate c++-- TLS 1.2 distinguishes session ID and session ticket. session+-- ticket. Session ticket is prioritized over session ID.+ticketOrSessionID12+ :: Maybe Ticket -> Session -> Maybe SessionIDorTicket+ticketOrSessionID12 (Just ticket) _+ | ticket /= "" = Just $ B.copy ticket+ticketOrSessionID12 _ (Session (Just sessionId)) = Just $ B.copy sessionId+ticketOrSessionID12 _ _ = Nothing++setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()+setPeerRecordSizeLimit ctx tls13 (RecordSizeLimit n0) = do+ when (n0 < 64) $+ throwCore $+ Error_Protocol ("too small recode size limit: " ++ show n0) IllegalParameter++ -- RFC 8449 Section 4:+ -- Even if a larger record size limit is provided by a peer, an+ -- endpoint MUST NOT send records larger than the protocol-defined+ -- limit, unless explicitly allowed by a future TLS version or+ -- extension.+ let n1 = fromIntegral n0+ n2+ | n1 > protolim = protolim+ | otherwise = n1+ -- Even if peer's value is larger than the protocol-defined+ -- limitation, call "setPeerRecordLimit" to send+ -- "record_size_limit" as ACK. In this case, the protocol-defined+ -- limitation is used.+ let lim = if tls13 then n2 - 1 else n2+ setPeerRecordLimit ctx $ Just lim+ where+ protolim+ | tls13 = defaultRecordSizeLimit + 1+ | otherwise = defaultRecordSizeLimit++----------------------------------------------------------------++generateFinished :: Context -> Version -> Role -> IO ByteString+generateFinished ctx ver role = do+ thash <- transcriptHash ctx "generateFinished"+ (mainSecret, cipher) <- usingHState ctx $ gets $ \hst ->+ (fromJust $ hstMainSecret hst, fromJust $ hstPendingCipher hst)+ return $+ if role == ClientRole+ then+ generateClientFinished ver cipher mainSecret thash+ else+ generateServerFinished ver cipher mainSecret thash++generateFinished'+ :: PRF -> ByteString -> Secret -> TranscriptHash -> ByteString+generateFinished' prf label mainSecret (TranscriptHash thash) = convert $ prf mainSecret seed 12+ where+ seed = label <> thash++generateClientFinished+ :: Version+ -> Cipher+ -> Secret+ -> TranscriptHash+ -> ByteString+generateClientFinished ver ciph =+ generateFinished' (getPRF ver ciph) "client finished"++generateServerFinished+ :: Version+ -> Cipher+ -> Secret+ -> TranscriptHash+ -> ByteString+generateServerFinished ver ciph =+ generateFinished' (getPRF ver ciph) "server finished"++----------------------------------------------------------------++-- initialize a new Handshake context (initial handshake or renegotiations)+startHandshake :: Context -> Version -> ClientRandom -> IO ()+startHandshake ctx ver crand =+ void $ swapMVar (ctxHandshakeState ctx) $ Just hs+ where+ hs = newEmptyHandshake ver crand++setServerHelloParameters12+ :: Context+ -> Version+ -- ^ chosen version+ -> ServerRandom+ -> Cipher+ -> Compression+ -> IO ()+setServerHelloParameters12 ctx ver sran cipher compression = do+ usingHState ctx $+ modify' $ \hst ->+ hst+ { hstServerRandom = Just sran+ , hstPendingCipher = Just cipher+ , hstPendingCompression = compression+ }+ transitTranscriptHash ctx "transit" (getHash ver cipher) False++-- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384+-- instead of the default SHA256.+getHash :: Version -> Cipher -> Hash+getHash ver ciph+ | ver < TLS12 = SHA1_MD5+ | maybe True (< TLS12) (cipherMinVer ciph) = SHA256+ | otherwise = cipherHash ciph++-- | when a new handshake is done, wrap up & clean up.+finishHandshake12 :: Context -> IO ()+finishHandshake12 ctx = do+ -- forget most handshake data and reset bytes counters.+ modifyMVar_ (ctxHandshakeState ctx) $ \case+ Nothing -> return Nothing+ Just hshake ->+ return $+ Just+ (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMainSecret = hstMainSecret hshake+ , hstExtendedMainSecret = hstExtendedMainSecret hshake+ , hstSupportedGroup = hstSupportedGroup hshake+ }+ updateMeasure ctx resetBytesCounters+ -- mark the secure connection up and running.+ setEstablished ctx Established
Network/TLS/Handshake/Common13.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -14,7 +15,6 @@ makePSKBinder, replacePSKBinder, sendChangeCipherSpec13,- handshakeDone13, makeCertRequest, createTLS13TicketInfo, ageToObfuscatedAge,@@ -37,11 +37,18 @@ calculateApplicationSecret, calculateResumptionSecret, derivePSK,- checkKeyShareKeyLength,+ checkClientKeyShareKeyLength,+ checkServerKeyShareKeyLength, setRTT,+ computeConfirm,+ updateTranscriptHash13,+ setServerHelloParameters13,+ finishHandshake13, ) where -import qualified Data.ByteArray as BA+import Control.Concurrent.MVar+import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.UnixTime import Foreign.C.Types (CTime (..))@@ -50,18 +57,20 @@ import Network.TLS.Crypto import qualified Network.TLS.Crypto.IES as IES +import Network.TLS.Compression import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname) import Network.TLS.Handshake.Common (unexpected) import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process (processHandshake13) import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC+import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -69,67 +78,71 @@ import Network.TLS.Types import Network.TLS.Wire -import Control.Concurrent.MVar-import Control.Monad.State.Strict- ---------------------------------------------------------------- -makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13+makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13 makeFinished ctx usedHash baseKey = do- verifyData <- makeVerifyData usedHash baseKey <$> transcriptHash ctx+ verifyData <-+ VerifyData . makeVerifyData usedHash baseKey+ <$> transcriptHash ctx "makeFinished" liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData pure $ Finished13 verifyData checkFinished- :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()-checkFinished ctx usedHash baseKey hashValue verifyData = do- let verifyData' = makeVerifyData usedHash baseKey hashValue+ :: MonadIO m+ => Context -> Hash -> Secret -> TranscriptHash -> VerifyData -> m ()+checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do+ let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash hashValue when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol "broken Finished" DecodeError- unless (verifyData' == verifyData) $ decryptError "cannot verify finished"- liftIO $ usingState_ ctx $ setVerifyDataForRecv verifyData+ unless (verifyData' == verifyData) $ decryptError "finished verification failed"+ liftIO $ usingState_ ctx $ setVerifyDataForRecv vd -makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString-makeVerifyData usedHash baseKey = hmac usedHash finishedKey+makeVerifyData :: Hash -> Secret -> TranscriptHash -> ByteString+makeVerifyData usedHash baseKey (TranscriptHash th) =+ hmac usedHash finishedKey th where hashSize = hashDigestSize usedHash finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize ---------------------------------------------------------------- -makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)+makeClientKeyShare+ :: Context -> Group -> IO ((Group, IES.GroupPrivate), KeyShareEntry)+makeClientKeyShare ctx grp = do+ (cpri, cpub) <- generateGroup ctx grp+ let wcpub = IES.groupEncodePublicA cpub+ clientKeyShare = KeyShareEntry grp wcpub+ return ((grp, cpri), clientKeyShare)++makeServerKeyShare :: Context -> KeyShareEntry -> IO (Secret, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter Right cpub -> do- ecdhePair <- generateECDHEShared ctx cpub+ ecdhePair <- encapsulateGroup ctx cpub case ecdhePair of Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter Just (spub, share) ->- let wspub = IES.encodeGroupPublic spub+ let wspub = IES.groupEncodePublicB spub serverKeyShare = KeyShareEntry grp wspub- in return (BA.convert share, serverKeyShare)+ in return (share, serverKeyShare) where- ecpub = IES.decodeGroupPublic grp wcpub+ ecpub = IES.groupDecodePublicA grp wcpub msgInvalidPublic = "invalid client " ++ show grp ++ " public key" -makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry)-makeClientKeyShare ctx grp = do- (cpri, cpub) <- generateECDHE ctx grp- let wcpub = IES.encodeGroupPublic cpub- clientKeyShare = KeyShareEntry grp wcpub- return (cpri, clientKeyShare)--fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString-fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of+fromServerKeyShare+ :: KeyShareEntry -> [(Group, IES.GroupPrivate)] -> IO Secret+fromServerKeyShare (KeyShareEntry grp wspub) grpCpris = case espub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter- Right spub -> case IES.groupGetShared spub cpri of- Just shared -> return $ BA.convert shared- Nothing ->- throwCore $- Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+ Right spub -> case lookup grp grpCpris of+ Nothing -> throwCore err+ Just cpri -> case IES.groupDecapsulate spub cpri of+ Just shared -> return shared+ Nothing -> throwCore err where- espub = IES.decodeGroupPublic grp wspub+ err = Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+ espub = IES.groupDecodePublicB grp wspub ---------------------------------------------------------------- @@ -144,15 +157,15 @@ => Context -> PubKey -> HashAndSignatureAlgorithm- -> ByteString+ -> TranscriptHash -> m Handshake13-makeCertVerify ctx pub hs hashValue = do+makeCertVerify ctx pub hs (TranscriptHash hashValue) = do role <- liftIO $ usingState_ ctx getRole let ctxStr | role == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue- CertVerify13 hs <$> sign ctx pub hs target+ CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target checkCertVerify :: MonadIO m@@ -162,18 +175,25 @@ -> 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+ verifyPublic ctx sigParams target signature makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do@@ -197,32 +217,30 @@ ---------------------------------------------------------------- makePSKBinder- :: Context- -> BaseSecret EarlySecret+ :: BaseSecret EarlySecret -> Hash -> Int- -> Maybe ByteString- -> IO ByteString-makePSKBinder ctx (BaseSecret sec) usedHash truncLen mch = do- rmsgs0 <- usingHState ctx getHandshakeMessagesRev -- fixme- let rmsgs = case mch of- Just ch -> trunc ch : rmsgs0- Nothing -> trunc (head rmsgs0) : tail rmsgs0- hChTruncated = hash usedHash $ B.concat $ reverse rmsgs- binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "")- return $ makeVerifyData usedHash binderKey hChTruncated+ -> ByteString+ -- ^ Encoded client hello+ -> ByteString+makePSKBinder (BaseSecret sec) usedHash truncLen ech =+ 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 where totalLen = B.length x takeLen = totalLen - truncLen -replacePSKBinder :: ByteString -> ByteString -> ByteString-replacePSKBinder pskz binder = identities `B.append` binders+replacePSKBinder :: ByteString -> [ByteString] -> ByteString+replacePSKBinder pskz bds = tLidentities <> binders where- bindersSize = B.length binder + 3- identities = B.take (B.length pskz - bindersSize) pskz- binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder+ tLidentities = B.take (B.length pskz - B.length binders) pskz+ -- See instance Extension PreSharedKey+ binders = runPut $ putOpaque16 $ runPut (mapM_ putBinder bds)+ putBinder = putOpaque8 ---------------------------------------------------------------- @@ -236,50 +254,27 @@ ---------------------------------------------------------------- --- | TLS13 handshake wrap up & clean up. Contrary to @handshakeDone@, this--- does not handle session, which is managed separately for TLS 1.3. This does--- not reset byte counters because renegotiation is not allowed. And a few more--- state attributes are preserved, necessary for TLS13 handshake modes, session--- tickets and post-handshake authentication.-handshakeDone13 :: Context -> IO ()-handshakeDone13 ctx = do- -- forget most handshake data- modifyMVar_ (ctxHandshakeState ctx) $ \case- Nothing -> return Nothing- Just hshake ->- return $- Just- (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMainSecret = hstMainSecret hshake- , hstSupportedGroup = hstSupportedGroup hshake- , hstHandshakeDigest = hstHandshakeDigest hshake- , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake- , hstTLS13RTT0Status = hstTLS13RTT0Status hshake- , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake- }- -- forget handshake data stored in TLS state- usingState_ ctx $ do- setTLS13KeyShare Nothing- setTLS13PreSharedKey Nothing- -- mark the secure connection up and running.- setEstablished ctx Established+makeCertRequest+ :: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13+makeCertRequest sparams ctx certReqCtx zlib =+ let sigAlgs = SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx+ signatureAlgExt = Just $ toExtensionRaw sigAlgs -----------------------------------------------------------------+ compCertExt+ | zlib = Just $ toExtensionRaw $ CompressCertificate [CCA_Zlib]+ | otherwise = Nothing -makeCertRequest :: ServerParams -> Context -> CertReqContext -> Handshake13-makeCertRequest sparams ctx certReqCtx =- let sigAlgs =- extensionEncode $- SignatureAlgorithms $- supportedHashSignatures $- ctxSupported ctx caDns = map extractCAname $ serverCACertificates sparams- caDnsEncoded = extensionEncode $ CertificateAuthorities caDns- caExtension- | null caDns = []- | otherwise = [ExtensionRaw EID_CertificateAuthorities caDnsEncoded]- crexts = ExtensionRaw EID_SignatureAlgorithms sigAlgs : caExtension+ caExt+ | null caDns = Nothing+ | otherwise = Just $ toExtensionRaw $ CertificateAuthorities caDns++ crexts =+ catMaybes+ [ {- 0x0d -} signatureAlgExt+ , {- 0x1b -} compCertExt+ , {- 0x2f -} caExt+ ] in CertRequest13 certReqCtx crexts ----------------------------------------------------------------@@ -389,7 +384,8 @@ ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)+newtype RecvHandshake13M m a+ = RecvHandshake13M (StateT [Handshake13R] m a) deriving (Functor, Applicative, Monad, MonadIO) recvHandshake13@@ -397,31 +393,41 @@ => Context -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a-recvHandshake13 ctx f = getHandshake13 ctx >>= f+recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h recvHandshake13hash :: MonadIO m => Context- -> (ByteString -> Handshake13 -> RecvHandshake13M m a)+ -> String+ -> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a-recvHandshake13hash ctx f = do- d <- transcriptHash ctx- getHandshake13 ctx >>= f d+recvHandshake13hash ctx label f = do+ d <- transcriptHash ctx label+ getHandshake13 ctx >>= \(h, _b) -> f d h -getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13+getHandshake13+ :: MonadIO m => Context -> RecvHandshake13M m Handshake13R getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of- (h : hs) -> found h hs- [] -> recvLoop+ hb : hbs -> found hb hbs+ _ -> recvLoop where- found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h+ found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of- Right (Handshake13 []) -> error "invalid recvPacket13 result"- Right (Handshake13 (h : hs)) -> found h hs- Right ChangeCipherSpec13 -> recvLoop+ Right (Handshake13 [] _) -> error "invalid recvPacket13 result"+ Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs+ Right ChangeCipherSpec13 -> do+ alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv+ if alreadyReceived+ then+ liftIO $ throwCore $ Error_Protocol "multiple CSS in TLS 1.3" UnexpectedMessage+ else do+ liftIO $ usingHState ctx $ setCCS13Recv True+ recvLoop+ Right (Alert13 _) -> throwCore Error_TCP_Terminate Right x -> unexpected (show x) (Just "handshake 13") Left err -> throwCore err @@ -442,6 +448,9 @@ in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool+isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13++{- isHashSignatureValid13 (HashIntrinsic, s) = s `elem` [ SignatureRSApssRSAeSHA256@@ -456,6 +465,7 @@ isHashSignatureValid13 (h, SignatureECDSA) = h `elem` [HashSHA256, HashSHA384, HashSHA512] isHashSignatureValid13 _ = False+-} ---------------------------------------------------------------- @@ -463,18 +473,13 @@ :: Context -> CipherChoice -> Either ByteString (BaseSecret EarlySecret)- -> Bool -> IO (SecretPair EarlySecret)-calculateEarlySecret ctx choice maux initialized = do- hCh <-- if initialized- then transcriptHash ctx- else do- hmsgs <- usingHState ctx getHandshakeMessages- return $ hash usedHash $ B.concat hmsgs+calculateEarlySecret ctx choice maux = do+ (_ch, b) <- fromJust <$> usingHState ctx getClientHello+ let hCh = TranscriptHash $ hashChunks usedHash b let earlySecret = case maux of Right (BaseSecret sec) -> sec- Left psk -> hkdfExtract usedHash zero psk+ Left psk -> hkdfExtract usedHash zero (convert psk) clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets@@ -489,20 +494,21 @@ sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice- zeroOrPSK = fromMaybe zero mpsk+ zeroOrPSK = fromMaybe zero (convert <$> mpsk) calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret- -> ByteString+ -> Secret -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do- hChSh <- transcriptHash ctx- let handshakeSecret =+ hChSh <- transcriptHash ctx "CH..SH"+ let th = TranscriptHash $ hash usedHash ""+ handshakeSecret = hkdfExtract usedHash- (deriveSecret usedHash sec "derived" (hash usedHash ""))+ (deriveSecret usedHash sec "derived" th) ecdhe let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh@@ -520,18 +526,19 @@ :: Context -> CipherChoice -> BaseSecret HandshakeSecret- -> ByteString+ -> TranscriptHash -> IO (SecretTriple ApplicationSecret) calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do- let applicationSecret =+ let th = TranscriptHash $ hash usedHash ""+ applicationSecret = hkdfExtract usedHash- (deriveSecret usedHash sec "derived" (hash usedHash ""))+ (deriveSecret usedHash sec "derived" th) zero let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf- usingState_ ctx $ setExporterSecret exporterSecret+ usingState_ ctx $ setTLS13ExporterSecret exporterSecret let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret@@ -551,15 +558,15 @@ -> BaseSecret ApplicationSecret -> IO (BaseSecret ResumptionSecret) calculateResumptionSecret ctx choice (BaseSecret sec) = do- hChCf <- transcriptHash ctx+ hChCf <- transcriptHash ctx "CH..CF" let resumptionSecret = deriveSecret usedHash sec "res master" hChCf return $ BaseSecret resumptionSecret where usedHash = cHash choice derivePSK- :: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString-derivePSK choice (BaseSecret sec) nonce =+ :: CipherChoice -> BaseSecret ResumptionSecret -> TicketNonce -> ByteString+derivePSK choice (BaseSecret sec) (TicketNonce nonce) = hkdfExpandLabel usedHash sec "resumption" nonce hashSize where usedHash = cHash choice@@ -567,28 +574,127 @@ ---------------------------------------------------------------- -checkKeyShareKeyLength :: KeyShareEntry -> Bool-checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key+checkClientKeyShareKeyLength :: KeyShareEntry -> Bool+checkClientKeyShareKeyLength ks = clientKeyShareKeyLength grp == B.length key where grp = keyShareEntryGroup ks key = keyShareEntryKeyExchange ks -keyShareKeyLength :: Group -> Int-keyShareKeyLength P256 = 65 -- 32 * 2 + 1-keyShareKeyLength P384 = 97 -- 48 * 2 + 1-keyShareKeyLength P521 = 133 -- 66 * 2 + 1-keyShareKeyLength X25519 = 32-keyShareKeyLength X448 = 56-keyShareKeyLength FFDHE2048 = 256-keyShareKeyLength FFDHE3072 = 384-keyShareKeyLength FFDHE4096 = 512-keyShareKeyLength FFDHE6144 = 768-keyShareKeyLength FFDHE8192 = 1024-keyShareKeyLength _ = error "keyShareKeyLength"+{- FOURMOLU_DISABLE -}+clientKeyShareKeyLength :: Group -> Int+clientKeyShareKeyLength P256 = 65 -- 32 * 2 + 1+clientKeyShareKeyLength P384 = 97 -- 48 * 2 + 1+clientKeyShareKeyLength P521 = 133 -- 66 * 2 + 1+clientKeyShareKeyLength X25519 = 32+clientKeyShareKeyLength X448 = 56+clientKeyShareKeyLength FFDHE2048 = 256+clientKeyShareKeyLength FFDHE3072 = 384+clientKeyShareKeyLength FFDHE4096 = 512+clientKeyShareKeyLength FFDHE6144 = 768+clientKeyShareKeyLength FFDHE8192 = 1024+clientKeyShareKeyLength MLKEM512 = 800+clientKeyShareKeyLength MLKEM768 = 1184+clientKeyShareKeyLength MLKEM1024 = 1568+clientKeyShareKeyLength X25519MLKEM768 = 1216+clientKeyShareKeyLength P256MLKEM768 = 1249+clientKeyShareKeyLength P384MLKEM1024 = 1665+clientKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -} +checkServerKeyShareKeyLength :: KeyShareEntry -> Bool+checkServerKeyShareKeyLength ks = serverKeyShareKeyLength grp == B.length key+ where+ grp = keyShareEntryGroup ks+ key = keyShareEntryKeyExchange ks++{- FOURMOLU_DISABLE -}+serverKeyShareKeyLength :: Group -> Int+serverKeyShareKeyLength P256 = 65 -- 32 * 2 + 1+serverKeyShareKeyLength P384 = 97 -- 48 * 2 + 1+serverKeyShareKeyLength P521 = 133 -- 66 * 2 + 1+serverKeyShareKeyLength X25519 = 32+serverKeyShareKeyLength X448 = 56+serverKeyShareKeyLength FFDHE2048 = 256+serverKeyShareKeyLength FFDHE3072 = 384+serverKeyShareKeyLength FFDHE4096 = 512+serverKeyShareKeyLength FFDHE6144 = 768+serverKeyShareKeyLength FFDHE8192 = 1024+serverKeyShareKeyLength MLKEM512 = 768+serverKeyShareKeyLength MLKEM768 = 1088+serverKeyShareKeyLength MLKEM1024 = 1568+serverKeyShareKeyLength X25519MLKEM768 = 1120+serverKeyShareKeyLength P256MLKEM768 = 1153+serverKeyShareKeyLength P384MLKEM1024 = 1665+serverKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -}+ setRTT :: Context -> Millisecond -> IO () setRTT ctx chSentTime = do shRecvTime <- getCurrentTimeFromBase let rtt' = shRecvTime - chSentTime rtt = if rtt' == 0 then 10 else rtt' modifyTLS13State ctx $ \st -> st{tls13stRTT = rtt}++computeConfirm+ :: (MonadFail m, MonadIO m)+ => Context -> Hash -> ServerHello -> ByteString -> m ByteString+computeConfirm ctx usedHash sh label = do+ (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello)+ TranscriptHash echConf <-+ transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh+ let prk = hkdfExtract usedHash "" $ unClientRandom chRandom+ return $ hkdfExpandLabel usedHash (convert prk) label echConf 8++----------------------------------------------------------------++setServerHelloParameters13+ :: Context -> Cipher -> Bool -> IO (Either TLSError ())+setServerHelloParameters13 ctx cipher isHRR = do+ transitTranscriptHash ctx "transit" (cipherHash cipher) isHRR+ usingHState ctx $ do+ hst <- get+ case hstPendingCipher hst of+ Nothing -> do+ put+ hst+ { hstPendingCipher = Just cipher+ , hstPendingCompression = nullCompression+ }+ return $ Right ()+ Just oldcipher+ | cipher == oldcipher -> return $ Right ()+ | otherwise ->+ return $+ Left $+ Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter++-- | TLS13 handshake wrap up & clean up. Contrary to+-- @finishHandshake12@, this does not handle session, which is managed+-- separately for TLS 1.3. This does not reset byte counters because+-- renegotiation is not allowed. And a few more state attributes are+-- preserved, necessary for TLS13 handshake modes, session tickets and+-- post-handshake authentication.+finishHandshake13 :: Context -> IO ()+finishHandshake13 ctx = do+ -- forget most handshake data+ modifyMVar_ (ctxHandshakeState ctx) $ \case+ Nothing -> return Nothing+ Just hshake ->+ return $+ Just+ (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMainSecret = hstMainSecret hshake+ , hstSupportedGroup = hstSupportedGroup hshake+ , hstTransHashState = hstTransHashState hshake+ , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake+ , hstTLS13RTT0Status = hstTLS13RTT0Status hshake+ , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake+ , hstTLS13ECHAccepted = hstTLS13ECHAccepted hshake+ }+ -- forget handshake data stored in TLS state+ usingState_ ctx $ do+ setTLS13KeyShare Nothing+ setTLS13PreSharedKey Nothing+ -- mark the secure connection up and running.+ setEstablished ctx Established
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
@@ -7,8 +7,8 @@ decryptRSA, verifyPublic, generateDHE,- generateECDHE,- generateECDHEShared,+ generateGroup,+ encapsulateGroup, generateFFDHE, generateFFDHEShared, versionCompatible,@@ -20,13 +20,14 @@ ) where import Control.Monad.State.Strict-+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Handshake.State import Network.TLS.Imports+import Network.TLS.Parameters import Network.TLS.State (withRNG) import Network.TLS.Struct import Network.TLS.Types@@ -35,7 +36,7 @@ {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem. -}-encryptRSA :: Context -> ByteString -> IO ByteString+encryptRSA :: Context -> Secret -> IO ByteString encryptRSA ctx content = do publicKey <- usingHState ctx getRemotePublicKey usingState_ ctx $ do@@ -53,7 +54,7 @@ Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent -decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString)+decryptRSA :: Context -> ByteString -> IO (Either KxError Secret) decryptRSA ctx econtent = do (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do@@ -69,12 +70,12 @@ generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp -generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic)-generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp+generateGroup :: Context -> Group -> IO (GroupPrivate, GroupPublicA)+generateGroup ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp -generateECDHEShared- :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))-generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub+encapsulateGroup+ :: Context -> GroupPublicA -> IO (Maybe (GroupPublicB, GroupKey))+encapsulateGroup ctx pub = usingState_ ctx $ withRNG $ groupEncapsulate pub generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp@@ -144,7 +145,7 @@ ---------------------------------------------------------------- class LogLabel a where- labelAndKey :: a -> (String, ByteString)+ labelAndKey :: a -> (String, Secret) instance LogLabel MainSecret where labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key)@@ -172,8 +173,10 @@ case mhst of Nothing -> return () Just hst -> do- let cr = unClientRandom $ hstClientRandom hst+ let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst)+ cr = unClientRandom crm (label, key) = labelAndKey logkey- ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key+ debugKeyLogger (ctxDebug ctx) $+ label ++ " " ++ dump cr ++ " " ++ dump (convert key) where- dump = init . tail . showBytesHex+ dump = init . drop 1 . showBytesHex
− Network/TLS/Handshake/Process.hs
@@ -1,35 +0,0 @@--- |--- process handshake message received-module Network.TLS.Handshake.Process (- processHandshake12,- processHandshake13,- startHandshake,-) where--import Control.Concurrent.MVar--import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-import Network.TLS.Sending-import Network.TLS.Struct-import Network.TLS.Struct13--processHandshake12 :: Context -> Handshake -> IO ()-processHandshake12 ctx hs = do- when (isHRR hs) $ usingHState ctx wrapAsMessageHash13- void $ updateHandshake12 ctx hs- where- isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand- isHRR _ = False--processHandshake13 :: Context -> Handshake13 -> IO ()-processHandshake13 ctx = void . updateHandshake13 ctx---- initialize a new Handshake context (initial handshake or renegotiations)-startHandshake :: Context -> Version -> ClientRandom -> IO ()-startHandshake ctx ver crand =- let hs = Just $ newEmptyHandshake ver crand- in void $ swapMVar (ctxHandshakeState ctx) hs
Network/TLS/Handshake/Random.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} module Network.TLS.Handshake.Random ( serverRandom,+ serverRandomECH,+ replaceServerRandomECH, clientRandom,- hrrRandom,- isHelloRetryRequest, isDowngraded, ) where import qualified Data.ByteString as B+ import Network.TLS.Context.Internal+import Network.TLS.Imports import Network.TLS.Struct -- | Generate a server random suitable for the version selected by the server@@ -36,6 +39,17 @@ pref <- getStateRNG ctx 24 return (pref `B.append` suff) +serverRandomECH :: Context -> IO ServerRandom+serverRandomECH ctx = do+ rnd <- getStateRNG ctx 24+ let zeros = "\x00\x00\x00\x00\x00\x00\x00\x00"+ return $ ServerRandom (rnd <> zeros)++replaceServerRandomECH :: ServerRandom -> ByteString -> ServerRandom+replaceServerRandomECH (ServerRandom rnd) bs = ServerRandom (rnd' <> bs)+ where+ rnd' = B.take 24 rnd+ -- | Test if the negotiated version was artificially downgraded (that is, for -- other reason than the versions supported by the client). isDowngraded :: Version -> [Version] -> ServerRandom -> Bool@@ -49,52 +63,11 @@ suffix11 `B.isSuffixOf` sr | otherwise = False -suffix12 :: B.ByteString-suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01]+suffix12 :: ByteString+suffix12 = "\x44\x4F\x57\x4E\x47\x52\x44\x01" -suffix11 :: B.ByteString-suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00]+suffix11 :: ByteString+suffix11 = "\x44\x4F\x57\x4E\x47\x52\x44\x00" clientRandom :: Context -> IO ClientRandom clientRandom ctx = ClientRandom <$> getStateRNG ctx 32--hrrRandom :: ServerRandom-hrrRandom =- ServerRandom $- B.pack- [ 0xCF- , 0x21- , 0xAD- , 0x74- , 0xE5- , 0x9A- , 0x61- , 0x11- , 0xBE- , 0x1D- , 0x8C- , 0x02- , 0x1E- , 0x65- , 0xB8- , 0x91- , 0xC2- , 0xA2- , 0x11- , 0x16- , 0x7A- , 0xBB- , 0x8C- , 0x5E- , 0x07- , 0x9E- , 0x09- , 0xE2- , 0xC8- , 0xA8- , 0x33- , 0x9C- ]--isHelloRetryRequest :: ServerRandom -> Bool-isHelloRetryRequest = (== hrrRandom)
Network/TLS/Handshake/Server.hs view
@@ -4,11 +4,13 @@ handshakeServer, handshakeServerWith, requestCertificateServer,- postHandshakeAuthServerWith,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..), ) where -import Control.Exception (bracket) import Control.Monad.State.Strict+import Data.Maybe import Network.TLS.Context.Internal import Network.TLS.Handshake.Common@@ -20,12 +22,8 @@ import Network.TLS.Handshake.Server.ServerHello13 import Network.TLS.Handshake.Server.TLS12 import Network.TLS.Handshake.Server.TLS13-import Network.TLS.IO import Network.TLS.Imports-import Network.TLS.State import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types -- Put the server context in handshake mode. --@@ -35,57 +33,57 @@ -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do- hss <- recvPacketHandshake ctx- case hss of- [ch] -> handshake sparams ctx ch- _ -> unexpected (show hss) (Just "client hello")+ hbs <- recvPacketHandshake ctx+ case hbs of+ chb : _ -> handshake sparams ctx chb+ _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()+handshakeServerWith+ :: ServerParams -> Context -> HandshakeR -> IO () handshakeServerWith = handshake -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter.--- This is useful when the client hello has been already poped from the recv layer to inspect the packet.+-- This is useful when the client hello has been already popped from the recv layer to inspect the packet. ----- When the function returns, a new handshake has been succesfully negociated.+-- When the function returns, a new handshake has been successfully negotiated. -- On any error, a HandshakeFailed exception is raised.-handshake :: ServerParams -> Context -> Handshake -> IO ()-handshake sparams ctx clientHello = do- (chosenVersion, ch) <- processClientHello sparams ctx clientHello+handshake :: ServerParams -> Context -> HandshakeR -> IO ()+handshake sparams ctx chb@(ClientHello ch, bs) = do+ (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs if chosenVersion == TLS13 then do -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry.- (mClientKeyShare, r0) <-- processClientHello13 sparams ctx ch- case mClientKeyShare of- Nothing -> do- sendHRR ctx r0 ch+ -- r0 :: Cipher, Hash, Bool+ (keyShareResult, r0, r1) <-+ processClientHello13 sparams ctx chI+ case keyShareResult of+ SelectKeyShareNotFound ->+ throwCore $+ Error_Protocol "no group in common with the client for HRR" HandshakeFailure+ SelectKeyShareHRR g -> do+ sendHRR ctx g r0 chI $ isJust mcrnd+ -- Don't reset ctxEstablished since 0-RTT data+ -- would be coming, which should be ignored. handshakeServer sparams ctx- Just cliKeyShare -> do- r1 <-- sendServerHello13 sparams ctx cliKeyShare r0 ch- recvClientSecondFlight13 sparams ctx r1 ch+ SelectKeyShareFound cliKeyShare -> do+ unless (checkClientKeyShareKeyLength cliKeyShare) $+ throwCore $+ Error_Protocol "broken key_share" IllegalParameter+ -- r2 :: ( SecretTriple ApplicationSecret+ -- , ClientTrafficSecret HandshakeSecret+ -- , Bool -- authenticated+ -- , Bool) -- rtt0OK+ r2 <-+ sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd+ recvClientSecondFlight13 sparams ctx r2 chI else do r <-- processClinetHello12 sparams ctx ch+ processClientHello12 sparams ctx chI+ updateTranscriptHash12 ctx chb resumeSessionData <-- sendServerHello12 sparams ctx r ch+ sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData--newCertReqContext :: Context -> IO CertReqContext-newCertReqContext ctx = getStateRNG ctx 32--requestCertificateServer :: ServerParams -> Context -> IO Bool-requestCertificateServer sparams ctx = do- tls13 <- tls13orLater ctx- supportsPHA <- usingState_ ctx getClientSupportsPHA- let ok = tls13 && supportsPHA- when ok $ do- certReqCtx <- newCertReqContext ctx- let certReq = makeCertRequest sparams ctx certReqCtx- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- addCertRequest13 ctx certReq- sendPacket13 ctx $ Handshake13 [certReq]- return ok+handshake _ _ (hs, _) = unexpected (show hs) (Just "client hello")
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -1,22 +1,41 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module Network.TLS.Handshake.Server.ClientHello ( processClientHello, ) where +import qualified Control.Exception as E+import Crypto.HPKE+import qualified Data.ByteString as BS++import Network.TLS.ECH.Config++import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Extension import Network.TLS.Handshake.Common-import Network.TLS.Handshake.Process+import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Measurement+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct+import Network.TLS.Types processClientHello- :: ServerParams -> Context -> Handshake -> IO (Version, CH)-processClientHello sparams ctx clientHello@(ClientHello legacyVersion cran compressions ch@CH{..}) = do+ :: ServerParams+ -> Context+ -> ClientHello+ -> [ByteString]+ -> IO+ ( Version+ , ClientHello+ , Maybe ClientRandom -- Just for ECH to keep the outer one for key log+ )+processClientHello sparams ctx ch@CH{..} b = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do@@ -28,8 +47,7 @@ eof <- ctxEOF ctx let renegotiation = established == Established && not eof when- ( renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)- )+ (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $ throwCore $ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation -- check if policy allow this new handshake to happens@@ -39,30 +57,30 @@ (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes - -- Handle Client hello- hrr <- usingState_ ctx getTLS13HRR- unless hrr $ startHandshake ctx legacyVersion cran- processHandshake12 ctx clientHello-- when (legacyVersion /= TLS12) $+ -- A legacy_version below TLS 1.2 is refused. One above it is not: a+ -- server negotiates the highest version it supports (RFC 5246 Appendix+ -- E.1), and with supported_versions present does not use legacy_version+ -- at all (RFC 8446 Section 4.2.1). Both are decided below.+ when (chVersion < TLS12) $ throwCore $- Error_Protocol (show legacyVersion ++ " is not supported") ProtocolVersion+ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when ( supportedFallbackScsv (ctxSupported ctx)- && (0x5600 `elem` chCiphers)- && legacyVersion < TLS12+ && (CipherId 0x5600 `elem` chCiphers)+ && chVersion < TLS12 ) $ throwCore $ Error_Protocol "fallback is not allowed" InappropriateFallback+ -- choosing TLS version- let clientVersions = case extensionLookup EID_SupportedVersions chExtensions- >>= extensionDecode MsgTClientHello of- Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == []- _ -> []- clientVersion = min TLS12 legacyVersion+ let extract (SupportedVersionsClientHello vers) = vers -- fixme: vers == []+ extract _ = []+ clientVersions =+ lookupAndDecode EID_SupportedVersions MsgTClientHello chExtensions [] extract+ clientVersion = min TLS12 chVersion serverVersions | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) | otherwise = supportedVersions $ ctxSupported ctx@@ -86,24 +104,91 @@ ProtocolVersion Just v -> return v - -- SNI (Server Name Indication)- let serverName = case extensionLookup EID_ServerName chExtensions >>= extensionDecode MsgTClientHello of- Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns)- where- toHostName (ServerNameHostName hostName) = Just hostName- toHostName (ServerNameOther _) = Nothing- _ -> Nothing- when (chosenVersion == TLS13) $ do- -- If this is done for TLS12, SSL Labs test does not continue, sigh.- mapM_ ensureNullCompression compressions+ -- Checking compression+ let nullComp = compressionID nullCompression+ case chosenVersion of+ TLS13 ->+ when (chComps /= [nullComp]) $+ throwCore $+ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter+ _ -> case find (== nullComp) chComps of+ Nothing ->+ throwCore $+ Error_Protocol+ "compressions must include nullCompression in TLS 1.2"+ IllegalParameter+ _ -> return ()++ -- Processing encrypted client hello+ (mClientHello', receivedECH) <-+ if chosenVersion == TLS13 && not (null (serverECHKey sparams))+ then do+ lookupAndDecodeAndDo+ EID_EncryptedClientHello+ MsgTClientHello+ chExtensions+ (return (Nothing, False))+ (\bs -> (,True) <$> decryptECH sparams ctx ch bs)+ else return (Nothing, False)+ case mClientHello' of+ Just chI -> do+ -- chI is created from diff.+ -- encodeHandshake is a MUST.+ setupI ctx chI $ [encodeHandshake $ ClientHello chI]+ return (chosenVersion, chI, Just chRandom)+ _ -> do+ setupO ctx ch b+ when (chosenVersion == TLS13) $ do+ let hasECHConf = not (null (sharedECHConfigList (serverShared sparams)))+ when (hasECHConf && not receivedECH) $+ usingHState ctx $+ setECHEE True+ when receivedECH $+ usingHState ctx $+ setECHEE True+ return (chosenVersion, ch, Nothing)++setupI :: Context -> ClientHello -> [ByteString] -> IO ()+setupI ctx chI@CH{..} b = do+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx TLS13 chRandom+ usingHState ctx $ setClientHello chI b+ let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName- return (chosenVersion, ch)-processClientHello _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in handshakeServerWith"- HandshakeFailure +setupO :: Context -> ClientHello -> [ByteString] -> IO ()+setupO ctx ch@CH{..} b = do+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx chVersion chRandom+ usingHState ctx $ setClientHello ch b+ let serverName = getServerName chExtensions+ maybe (return ()) (usingState_ ctx . setClientSNI) serverName++-- SNI (Server Name Indication)+getServerName :: [ExtensionRaw] -> Maybe HostName+getServerName chExts =+ lookupAndDecode+ EID_ServerName+ MsgTClientHello+ chExts+ Nothing+ extractServerName+ where+ 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 = case filter (clientVersion >=) $ sortOn Down allowedVersions of@@ -117,3 +202,119 @@ where svs = sortOn Down serverVersions cvs = sortOn Down $ filter (>= TLS12) clientVersions++decryptECH+ :: ServerParams+ -> Context+ -> ClientHello+ -> EncryptedClientHello+ -> IO (Maybe ClientHello)+decryptECH _ _ _ ECHClientHelloInner = return Nothing+decryptECH sparams ctx chO ech@ECHClientHelloOuter{..} = E.handle hpkeHandler $ do+ mfunc <- getHPKE sparams ctx ech+ case mfunc of+ Nothing -> return Nothing+ Just (func, nenc) -> do+ hrr <- usingState_ ctx getTLS13HRR+ let nenc' = if hrr then 0 else nenc+ let aad = encodeHandshake' $ ClientHello $ fill0ClientHello nenc' chO+ plaintext <- func aad echPayload+ case decodeClientHello' plaintext of+ Right (ClientHello chI) -> do+ case expandClientHello chI chO of+ Nothing -> return Nothing+ Just chI' -> return $ Just chI'+ _ -> return Nothing+ where+ hpkeHandler :: HPKEError -> IO (Maybe ClientHello)+ hpkeHandler _ = return Nothing+decryptECH _ _ _ _ = return Nothing++fill0ClientHello :: Int -> ClientHello -> ClientHello+fill0ClientHello nenc ch@CH{..} =+ ch{chExtensions = fill0Exts nenc chExtensions}++fill0Exts :: Int -> [ExtensionRaw] -> [ExtensionRaw]+fill0Exts nenc xs0 = loop xs0+ where+ loop [] = []+ loop (ExtensionRaw EID_EncryptedClientHello bs : xs) = x' : loop xs+ where+ (prefix, payload) = BS.splitAt (10 + nenc) bs+ bs' = prefix <> BS.replicate (BS.length payload) 0+ x' = ExtensionRaw EID_EncryptedClientHello bs'+ loop (x : xs) = x : loop xs++expandClientHello :: ClientHello -> ClientHello -> Maybe ClientHello+expandClientHello inner outer =+ case expand (chExtensions inner) (chExtensions outer) of+ Nothing -> Nothing+ Just exts ->+ Just $+ inner+ { chSession = chSession outer+ , chExtensions = exts+ }+ where+ expand :: [ExtensionRaw] -> [ExtensionRaw] -> Maybe [ExtensionRaw]+ expand [] _ = Just []+ expand iis [] = chk iis+ expand (i : is) oos = do+ (rs, oos') <- case i of+ ExtensionRaw EID_EchOuterExtensions bs ->+ case extensionDecode MsgTClientHello bs of+ Nothing -> Nothing+ Just (EchOuterExtensions eids) -> expd eids oos+ _ -> Just ([i], oos)+ (rs ++) <$> expand is oos'+ expd+ :: [ExtensionID] -> [ExtensionRaw] -> Maybe ([ExtensionRaw], [ExtensionRaw])+ expd [] oos = Just ([], oos)+ expd _ [] = Nothing+ expd (i : is) oos = case fnd i oos of+ Nothing -> Nothing+ Just (ext, oos') -> do+ (exts, oos'') <- expd is oos'+ Just (ext : exts, oos'')+ fnd :: ExtensionID -> [ExtensionRaw] -> Maybe (ExtensionRaw, [ExtensionRaw])+ fnd _ [] = Nothing+ fnd EID_EncryptedClientHello _ = Nothing+ fnd i (o@(ExtensionRaw eid _) : os)+ | i == eid = Just (o, os)+ | otherwise = fnd i os+ chk :: [ExtensionRaw] -> Maybe [ExtensionRaw]+ chk [] = Just []+ chk (ExtensionRaw EID_EchOuterExtensions _ : _) = Nothing+ chk (i : is) = (i :) <$> chk is++getHPKE+ :: ServerParams+ -> Context+ -> EncryptedClientHello+ -> IO (Maybe (HPKEF, Int))+getHPKE ServerParams{..} ctx ECHClientHelloOuter{..} = do+ mfunc <- getTLS13HPKE ctx+ case mfunc of+ Nothing -> do+ let mconfig = findECHConfigById echConfigId $ sharedECHConfigList serverShared+ mskR = lookup echConfigId serverECHKey+ case (mconfig, mskR) of+ (Just config, Just skR') -> do+ let kemid = KEM_ID $ kem_id $ key_config $ contents config+ skR = EncodedSecretKey skR'+ encodedConfig = encodeECHConfig config+ 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+ setTLS13HPKE ctx func nenc+ return $ Just (func, nenc)+ _ -> return Nothing+ _ -> return mfunc+getHPKE _ _ _ = return Nothing++findECHConfigById :: ConfigId -> ECHConfigList -> Maybe ECHConfig+findECHConfigById cnfId echConfigList = find eqCfgId echConfigList+ where+ eqCfgId cnf = config_id (key_config (contents cnf)) == cnfId
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ClientHello12 (- processClinetHello12,+ processClientHello12, ) where import Network.TLS.Cipher@@ -11,50 +11,95 @@ import Network.TLS.Crypto import Network.TLS.ErrT import Network.TLS.Extension-import Network.TLS.Handshake.Common+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 (Role (..))+import Network.TLS.Types (CipherId (..), Role (..)) ---------------------------------------------------------------- +-- serverSupported sparams == ctxSupported ctx+ -- TLS 1.2 or earlier-processClinetHello12+processClientHello12 :: ServerParams -> Context- -> CH+ -> ClientHello -> IO (Cipher, Maybe Credential)-processClinetHello12 sparams ctx ch = do- let secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx- when secureRenegotiation $ checkSesecureRenegotiation ctx ch+processClientHello12 sparams ctx ch = do+ let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams+ when secureRenegotiation $ checkSecureRenegotiation ctx ch+ checkEcPointFormats ch serverName <- usingState_ ctx getClientSNI- extraCreds <- onServerNameIndication (serverHooks sparams) serverName+ let hooks = serverHooks sparams+ extraCreds <- onServerNameIndication hooks serverName let (creds, signatureCreds, ciphersFilteredVersion) =- credsTriple sparams ctx ch extraCreds+ credsTriple sparams ch extraCreds -- 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 (serverHooks sparams) TLS12 ciphersFilteredVersion+ usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds return (usedCipher, mcred) -checkSesecureRenegotiation :: Context -> CH -> IO ()-checkSesecureRenegotiation ctx CH{..} = do+-- 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 (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 Just content -> usingState_ ctx $ do- cvd <- getVerifyData ClientRole+ VerifyData cvd <- getVerifyData ClientRole let bs = extensionEncode (SecureRenegotiation cvd "") unless (bs == content) $ throwError $@@ -69,19 +114,23 @@ credsTriple :: ServerParams- -> Context- -> CH+ -> ClientHello -> Credentials -> (Credentials, Credentials, [Cipher])-credsTriple sparams ctx CH{..} extraCreds+credsTriple sparams CH{..} extraCreds | cipherListCredentialFallback cltCiphers = (allCreds, sigAllCreds, allCiphers) | otherwise = (cltCreds, sigCltCreds, cltCiphers) where- commonCiphers creds sigCreds = filter ((`elem` chCiphers) . cipherID) (getCiphers sparams creds sigCreds)+ ciphers = supportedCiphers $ serverSupported sparams + commonCiphers creds sigCreds = intersectCiphers chCiphers availableCiphers+ where+ availableCiphers = getCiphers ciphers creds sigCreds++ p = makeCredentialPredicate TLS12 chExtensions allCreds =- filterCredentials (isCredentialAllowed TLS12 chExtensions) $- extraCreds `mappend` sharedCredentials (ctxShared ctx)+ filterCredentials (isCredentialAllowed TLS12 p) $+ extraCreds `mappend` sharedCredentials (serverShared sparams) -- When selecting a cipher we must ensure that it is allowed for the -- TLS version but also that all its key-exchange requirements@@ -95,10 +144,12 @@ -- 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. - possibleGroups = negotiatedGroupsInCommon ctx chExtensions+ supported = serverSupported sparams+ groups = supportedGroups supported+ possibleGroups = negotiatedGroupsInCommon groups chExtensions possibleECGroups = possibleGroups `intersect` availableECGroups possibleFFGroups = possibleGroups `intersect` availableFFGroups hasCommonGroupForECDHE = not (null possibleECGroups)@@ -121,7 +172,8 @@ -- Build a list of all hash/signature algorithms in common between -- client and server.- possibleHashSigAlgs = hashAndSignaturesInCommon ctx chExtensions+ hashAndSignatures = supportedHashSignatures supported+ possibleHashSigAlgs = hashAndSignaturesInCommon hashAndSignatures chExtensions -- Check that a candidate signature credential will be compatible with -- client & server hash/signature algorithms. This returns Just Int@@ -162,32 +214,42 @@ ---------------------------------------------------------------- -hashAndSignaturesInCommon- :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]-hashAndSignaturesInCommon ctx exts =- let cHashSigs = case extensionLookup EID_SignatureAlgorithms exts- >>= extensionDecode MsgTClientHello of- -- See Section 7.4.1.4.1 of RFC 5246.- Nothing ->- [ (HashSHA1, SignatureECDSA)- , (HashSHA1, SignatureRSA)- , (HashSHA1, SignatureDSA)- ]- Just (SignatureAlgorithms sas) -> sas- sHashSigs = supportedHashSignatures $ ctxSupported ctx- in -- The values in the "signature_algorithms" extension- -- are in descending order of preference.- -- However here the algorithms are selected according- -- to server preference in 'supportedHashSignatures'.- sHashSigs `intersect` cHashSigs+-- 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 :: Context -> [ExtensionRaw] -> [Group]-negotiatedGroupsInCommon ctx exts = case extensionLookup EID_SupportedGroups exts- >>= extensionDecode MsgTClientHello of- Just (SupportedGroups clientGroups) ->- let serverGroups = supportedGroups (ctxSupported ctx)- in serverGroups `intersect` clientGroups- _ -> []+negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]+negotiatedGroupsInCommon serverGroups exts =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ exts+ []+ (\(SupportedGroups clientGroups) -> serverGroups `intersect` clientGroups) ---------------------------------------------------------------- @@ -217,8 +279,8 @@ -- subset of this list named 'sigCreds'. This list has been filtered in order -- to remove certificates that are not compatible with hash/signature -- restrictions (TLS 1.2).-getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]-getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams)+getCiphers :: [Cipher] -> Credentials -> Credentials -> [Cipher]+getCiphers ciphers creds sigCreds = filter authorizedCKE ciphers where authorizedCKE cipher = case cipherKeyExchange cipher of
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -3,32 +3,42 @@ module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13,- sendHRR,+ SelectKeyShareResult (..), ) where +import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension-import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Random+import Network.TLS.Handshake.Server.Common+import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters+import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct-import Network.TLS.Struct13+import Network.TLS.Types +limitSupportedGroups :: Int+limitSupportedGroups = 64+ -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context- -> CH- -> IO (Maybe KeyShareEntry, (Cipher, Hash, Bool))-processClientHello13 sparams ctx CH{..} = do+ -> ClientHello+ -> IO+ ( SelectKeyShareResult+ , (Cipher, Hash, Bool) -- rtt0+ , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN+ )+processClientHello13 sparams ctx ch@CH{..} = do when (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions) $ throwCore@@ -40,80 +50,173 @@ 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- rtt0 = case extensionLookup EID_EarlyData chExtensions >>= extensionDecode MsgTClientHello of- Just (EarlyDataIndication _) -> True- Nothing -> False- when rtt0 $- -- mark a 0-RTT attempt before a possible HRR, and before updating the- -- status again if 0-RTT successful- setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding- -- Deciding key exchange from key shares- keyShares <- case extensionLookup EID_KeyShare chExtensions of- Nothing ->+ usedCipher <- chooseCipher (serverHooks sparams) TLS13 ciphersFilteredVersion+ let usedHash = cipherHash usedCipher+ rtt0 =+ lookupAndDecode+ EID_EarlyData+ MsgTClientHello+ chExtensions+ False+ (\(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+ else+ -- In the case of HRR, EarlyDataNotAllowed is already set.+ -- It should be cleared here.+ setEstablished ctx NotEstablished+ -- Deciding key exchange from key shares+ let require = throwCore $ Error_Protocol "key exchange not implemented, expected key_share extension" MissingExtension- Just kss -> case extensionDecode MsgTClientHello kss of- Just (KeyShareClientHello kses) -> return kses- Just _ ->- error "processClientHello13: invalid KeyShare value"- _ ->- throwCore $ Error_Protocol "broken key_share" DecodeError- mshare <- findKeyShare keyShares serverGroups- return (mshare, (usedCipher, usedHash, rtt0))+ extract (KeyShareClientHello kses) = return kses+ extract _ = require+ keyShares <-+ lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract+ let clientGroups =+ take limitSupportedGroups $+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExtensions+ []+ (\(SupportedGroups gs) -> gs)+ (mgroup, doHRR) <-+ onSelectKeyShare+ (serverHooks sparams)+ serverGroups+ clientGroups+ $ map keyShareEntryGroup keyShares+ keyshareResult <- case mgroup of+ Nothing -> return SelectKeyShareNotFound+ Just g+ | doHRR -> return $ SelectKeyShareHRR g+ | otherwise -> case filter (\e -> keyShareEntryGroup e == g) keyShares of+ [] -> return SelectKeyShareNotFound+ [x] -> return $ SelectKeyShareFound x+ _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter++ let triple = (usedCipher, usedHash, rtt0)+ pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch+ (ich, b) <- fromJust <$> usingHState ctx getClientHello+ updateTranscriptHash12 ctx (ClientHello ich, b)+ return (keyshareResult, triple, pskEarlySecret) where- ciphersFilteredVersion = filter ((`elem` chCiphers) . cipherID) serverCiphers+ ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers = filter (cipherAllowedForVersion TLS13) (supportedCiphers $ serverSupported sparams)- serverGroups = supportedGroups (ctxSupported ctx)+ serverGroups = supportedGroupsTLS13 $ serverSupported sparams -findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)-findKeyShare ks ggs = go ggs+data SelectKeyShareResult+ = -- | Negotiation failure+ SelectKeyShareNotFound+ | -- | Send a hello retry request with this group+ SelectKeyShareHRR Group+ | -- | Use this key share+ SelectKeyShareFound KeyShareEntry+ deriving (Eq, Show)++pskAndEarlySecret+ :: ServerParams+ -> Context+ -> (Cipher, Hash, Bool) -- rtt0+ -> ClientHello+ -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN+pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do+ (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, ticketALPN) where- go [] = return Nothing- go (g : gs) = case filter (grpEq g) ks of- [] -> go gs- [k] -> do- unless (checkKeyShareKeyLength k) $- throwCore $- Error_Protocol "broken key_share" IllegalParameter- return $ Just k- _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter- grpEq g ent = g == keyShareEntryGroup ent+ choice = makeCipherChoice TLS13 usedCipher -sendHRR :: Context -> (Cipher, a, b) -> CH -> IO ()-sendHRR ctx (usedCipher, _, _) CH{..} = do- twice <- usingState_ ctx getTLS13HRR- when twice $- throwCore $- Error_Protocol "Hello retry not allowed again" HandshakeFailure- usingState_ ctx $ setTLS13HRR True- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- let clientGroups = case extensionLookup EID_SupportedGroups chExtensions- >>= extensionDecode MsgTClientHello of- Just (SupportedGroups gs) -> gs- Nothing -> []- possibleGroups = serverGroups `intersect` clientGroups- case possibleGroups of- [] ->+ choosePSK =+ lookupAndDecodeAndDo+ EID_PreSharedKey+ MsgTClientHello+ chExtensions+ (return (zero, Nothing, False, Nothing))+ selectPSK++ selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do+ when (null dhModes) $ throwCore $- Error_Protocol "no group in common with the client for HRR" HandshakeFailure- g : _ -> do- let serverKeyShare = extensionEncode $ KeyShareHRR g- selectedVersion = extensionEncode $ SupportedVersionsServerHello TLS13- extensions =- [ ExtensionRaw EID_KeyShare serverKeyShare- , ExtensionRaw EID_SupportedVersions selectedVersion- ]- hrr = ServerHello13 hrrRandom chSession (cipherID usedCipher) extensions- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- runPacketFlight ctx $ do- loadPacket13 ctx $ Handshake13 [hrr]- sendChangeCipherSpec13 ctx- where- serverGroups = supportedGroups (ctxSupported ctx)+ 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+ -- 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+ return+ ( psk+ , Just (bnd, 0 :: Int, len)+ , is0RTTvalid+ , sessionALPN sdata+ )+ else -- fall back to full handshake+ return (zero, Nothing, False, Nothing)+ _ -> return (zero, Nothing, False, Nothing)+ else return (zero, Nothing, False, Nothing)+ selectPSK _ = return (zero, Nothing, False, Nothing)++ 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+ unless (binder == binder') $+ decryptError "PSK binder validation failed"+ return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]++ checkSessionEquality sdata = do+ msni <- usingState_ ctx getClientSNI+ let isSameSNI = sessionClientSNI sdata == msni+ isSameCipher = sessionCipher sdata == cipherID usedCipher+ ciphers = supportedCiphers $ serverSupported sparams+ scid = sessionCipher sdata+ isSameKDF = case findCipher scid ciphers of+ Nothing -> False+ Just c -> cipherHash c == cipherHash usedCipher+ isSameVersion = TLS13 == sessionVersion sdata+ isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required+ is0RTTvalid = isSameVersion && isSameCipher+ return (isPSKvalid, is0RTTvalid)++ dhModes =+ lookupAndDecode+ EID_PskKeyExchangeModes+ MsgTClientHello+ chExtensions+ []+ (\(PskKeyExchangeModes ms) -> ms)++ hashSize = hashDigestSize usedHash+ zero = B.replicate hashSize 0
Network/TLS/Handshake/Server/Common.hs view
@@ -2,18 +2,23 @@ module Network.TLS.Handshake.Server.Common ( applicationProtocol,+ chooseCipher, checkValidClientCertChain, clientCertificate, credentialDigitalSignatureKey, filterCredentials, filterCredentialsWithHashSignatures,+ makeCredentialPredicate, isCredentialAllowed, storePrivInfoServer,+ hashAndSignaturesInCommon,+ processRecordSizeLimit, ) where import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..))+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) +import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Credentials import Network.TLS.Crypto@@ -29,6 +34,18 @@ import Network.TLS.Util (catchException) import Network.TLS.X509 +chooseCipher :: ServerHooks -> Version -> [Cipher] -> IO Cipher+chooseCipher hooks ver candidates =+ 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+ selected = onCipherChoosing hooks ver candidates+ checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain checkValidClientCertChain ctx errmsg = do@@ -50,20 +67,25 @@ filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials filterCredentials p (Credentials l) = Credentials (filter p l) -isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool-isCredentialAllowed ver exts cred =+-- ECDSA keys are tested against supported elliptic curves until TLS12 but+-- not after. With TLS13, the curve is linked to the signature algorithm+-- and client support is tested with signatureCompatible13.+makeCredentialPredicate :: Version -> [ExtensionRaw] -> (Group -> Bool)+makeCredentialPredicate ver exts+ | ver >= TLS13 = const True+ | otherwise =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ exts+ (const True)+ (\(SupportedGroups sg) -> (`elem` sg))++isCredentialAllowed :: Version -> (Group -> Bool) -> Credential -> Bool+isCredentialAllowed ver p cred = pubkey `versionCompatible` ver && satisfiesEcPredicate p pubkey where (pubkey, _) = credentialPublicPrivateKeys cred- -- ECDSA keys are tested against supported elliptic curves until TLS12 but- -- not after. With TLS13, the curve is linked to the signature algorithm- -- and client support is tested with signatureCompatible13.- p- | ver < TLS13 = case extensionLookup EID_SupportedGroups exts- >>= extensionDecode MsgTClientHello of- Nothing -> const True- Just (SupportedGroups sg) -> (`elem` sg)- | otherwise = const True -- Filters a list of candidate credentials with credentialMatchesHashSignatures. --@@ -86,42 +108,54 @@ filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials filterCredentialsWithHashSignatures exts =- case withExt EID_SignatureAlgorithmsCert of- Just (SignatureAlgorithmsCert sas) -> withAlgs sas- Nothing ->- case withExt EID_SignatureAlgorithms of- Nothing -> id- Just (SignatureAlgorithms sas) -> withAlgs sas+ lookupAndDecode+ EID_SignatureAlgorithmsCert+ MsgTClientHello+ exts+ lookupSignatureAlgorithms+ (\(SignatureAlgorithmsCert sas) -> withAlgs sas) where- withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello+ lookupSignatureAlgorithms =+ lookupAndDecode+ EID_SignatureAlgorithms+ MsgTClientHello+ exts+ id+ (\(SignatureAlgorithms sas) -> withAlgs sas) withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) storePrivInfoServer :: MonadIO m => Context -> Credential -> m () storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey) +-- ALPN (Application Layer Protocol Negotiation) applicationProtocol- :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]-applicationProtocol ctx exts sparams = do- -- ALPN (Application Layer Protocol Negotiation)- case extensionLookup EID_ApplicationLayerProtocolNegotiation exts- >>= extensionDecode MsgTClientHello of- Nothing -> return []- Just (ApplicationLayerProtocolNegotiation protos) -> do- case onALPNClientSuggest $ serverHooks sparams of- Just io -> do- proto <- io protos- when (proto == "") $- throwCore $- Error_Protocol "no supported application protocols" NoApplicationProtocol- usingState_ ctx $ do- setExtensionALPN True- setNegotiatedProtocol proto- return- [ ExtensionRaw- EID_ApplicationLayerProtocolNegotiation- (extensionEncode $ ApplicationLayerProtocolNegotiation [proto])- ]- _ -> return []+ :: Context -> [ExtensionRaw] -> ServerParams -> IO (Maybe ExtensionRaw)+applicationProtocol ctx exts sparams = case onALPN of+ Nothing -> return Nothing+ Just io ->+ lookupAndDecodeAndDo+ EID_ApplicationLayerProtocolNegotiation+ MsgTClientHello+ exts+ (return Nothing)+ $ select io+ where+ onALPN = onALPNClientSuggest $ serverHooks sparams+ select io (ApplicationLayerProtocolNegotiation protos) = do+ proto <- io protos+ 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+ let alpn = ApplicationLayerProtocolNegotiation [proto]+ return $ Just $ toExtensionRaw alpn clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do@@ -136,9 +170,57 @@ (onClientCertificate (serverHooks sparams) certs) rejectOnException case usage of- CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ CertificateUsageAccept -> do+ verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs CertificateUsageReject reason -> certificateRejected reason -- Remember cert chain for later use. -- usingHState ctx $ setClientCertChain certs++----------------------------------------------------------------++-- The values in the "signature_algorithms" extension+-- are in descending order of preference.+-- However here the algorithms are selected according+-- to server preference in 'supportedHashSignatures'.+hashAndSignaturesInCommon+ :: [HashAndSignatureAlgorithm] -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]+hashAndSignaturesInCommon sHashSigs exts = sHashSigs `intersect` cHashSigs+ where+ -- See Section 7.4.1.4.1 of RFC 5246.+ defVal =+ [ (HashSHA1, SignatureECDSA)+ , (HashSHA1, SignatureRSA)+ , (HashSHA1, SignatureDSA)+ ]+ cHashSigs =+ lookupAndDecode+ EID_SignatureAlgorithms+ MsgTClientHello+ exts+ defVal+ (\(SignatureAlgorithms sas) -> sas)++processRecordSizeLimit+ :: Context -> [ExtensionRaw] -> Bool -> IO (Maybe ExtensionRaw)+processRecordSizeLimit ctx chExts tls13 = do+ let mmylim = limitRecordSize $ sharedLimit $ ctxShared ctx+ setMyRecordLimit ctx mmylim+ case mmylim of+ Nothing -> return Nothing+ Just mylim -> do+ lookupAndDecodeAndDo+ EID_RecordSizeLimit+ MsgTClientHello+ chExts+ (return ())+ (setPeerRecordSizeLimit ctx tls13)+ peerSentRSL <- checkPeerRecordLimit ctx+ if peerSentRSL+ then do+ let mysiz = fromIntegral mylim + if tls13 then 1 else 0+ rsl = RecordSizeLimit mysiz+ return $ Just $ toExtensionRaw rsl+ else return Nothing
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -5,6 +5,8 @@ sendServerHello12, ) where +import Data.ByteArray (convert)+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -31,63 +33,70 @@ :: ServerParams -> Context -> (Cipher, Maybe Credential)- -> CH+ -> ClientHello -> IO (Maybe SessionData) sendServerHello12 sparams ctx (usedCipher, mcred) ch@CH{..} = do resumeSessionData <- recoverSessionData ctx ch case resumeSessionData of Nothing -> do serverSession <- newSession ctx- usingState_ ctx $ setSession serverSession False- serverhello <-- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession+ usingState_ ctx $ setSession serverSession+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions- let ff = serverhello : build [ServerHelloDone]- sendPacket12 ctx $ Handshake ff+ let ff = ServerHello sh : build [ServerHelloDone]+ sendPacket12 ctx $ Handshake ff [] contextFlush ctx Just sessionData -> do- usingState_ ctx $ setSession chSession True- serverhello <-+ usingState_ ctx $ do+ setSession chSession+ setTLS12SessionResuming True+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession- sendPacket12 ctx $ Handshake [serverhello]- let mainSecret = sessionSecret sessionData+ sendPacket12 ctx $ Handshake [ServerHello sh] []+ let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole return resumeSessionData -recoverSessionData :: Context -> CH -> IO (Maybe SessionData)+recoverSessionData :: Context -> ClientHello -> IO (Maybe SessionData) recoverSessionData ctx CH{..} = do serverName <- usingState_ ctx getClientSNI ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions let mticket =- extensionLookup EID_SessionTicket chExtensions- >>= extensionDecode MsgTClientHello- case mticket of- Just (SessionTicket ticket) | ticket /= "" -> do- sd <- sessionResume (sharedSessionManager $ ctxShared ctx) ticket- validateSession chCiphers serverName ems sd- _ -> case chSession of- (Session (Just clientSessionId)) -> do- sd <- sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId- validateSession chCiphers serverName ems sd- (Session Nothing) -> return Nothing+ lookupAndDecode+ EID_SessionTicket+ MsgTClientHello+ chExtensions+ Nothing+ (\(SessionTicket ticket) -> Just ticket)+ midentity = ticketOrSessionID12 mticket chSession+ case midentity of+ Nothing -> return Nothing+ Just identity -> do+ sd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity+ validateSession ctx chCiphers serverName ems sd validateSession- :: [CipherID]+ :: Context+ -> [CipherId] -> Maybe HostName -> Bool -> Maybe SessionData -> IO (Maybe SessionData)-validateSession _ _ _ Nothing = return Nothing-validateSession ciphers sni ems m@(Just sd)+validateSession _ _ _ _ Nothing = return Nothing+validateSession ctx ciphers sni ems m@(Just sd) -- SessionData parameters are assumed to match the local server configuration -- so we need to compare only to ClientHello inputs. Abbreviated handshake -- uses the same server_name than full handshake so the same -- credentials (and thus ciphers) are available. | TLS12 < sessionVersion sd = return Nothing -- fixme- | sessionCipher sd `notElem` ciphers = return Nothing- | isJust sni && sessionClientSNI sd /= sni = return Nothing+ | CipherId (sessionCipher sd) `notElem` ciphers =+ throwCore $+ Error_Protocol "new cipher is different from the old one" IllegalParameter+ | isJust sni && sessionClientSNI sd /= sni = do+ usingState_ ctx clearClientSNI+ return Nothing | ems && not emsSession = return Nothing | not ems && emsSession = let err = "client resumes an EMS session without EMS"@@ -103,12 +112,12 @@ -> Maybe Credential -> [ExtensionRaw] -> IO ([Handshake] -> [Handshake])-sendServerFirstFlight sparams ctx usedCipher mcred chExts = do+sendServerFirstFlight ServerParams{..} ctx usedCipher mcred chExts = do let b0 = id let cc = case mcred of Just (srvCerts, _) -> srvCerts _ -> CertificateChain []- let b1 = b0 . (Certificate cc :)+ let b1 = b0 . (Certificate (CertificateChain_ cc) :) usingState_ ctx $ setServerCertificateChain cc -- send server key exchange if needed@@ -130,26 +139,34 @@ -- -- Client certificates MUST NOT be accepted if not requested. --- if serverWantClientCert sparams+ if serverWantClientCert then do let (certTypes, hashSigs) =- let as = supportedHashSignatures $ ctxSupported ctx- in (nub $ mapMaybe hashSigToCertType as, as)+ let as = supportedHashSignatures serverSupported+ in (nub $ mapMaybe (fmap certTypeOnWire . hashSigToCertType) as, as) creq = CertRequest certTypes hashSigs- (map extractCAname $ serverCACertificates sparams)+ (map extractCAname serverCACertificates) usingHState ctx $ setCertReqSent True 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 setup_DHE = do- let possibleFFGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableFFGroups+ let possibleFFGroups = commonGroups `intersect` availableFFGroups (dhparams, priv, pub) <- case possibleFFGroups of [] ->- let dhparams = fromJust $ serverDHEParams sparams+ let dhparams = fromJust serverDHEParams in case findFiniteFieldGroup dhparams of Just g -> do usingHState ctx $ setSupportedGroup g@@ -174,8 +191,7 @@ -- If RSA is also used for key exchange, this function is -- not called. decideHashSig pubKey = do- let hashSigs = hashAndSignaturesInCommon ctx chExts- case filter (pubKey `signatureCompatible`) hashSigs of+ case filter (pubKey `signatureCompatible`) commonHashSigs of [] -> error ("no hash signature for " ++ pubkeyType pubKey) x : _ -> return x @@ -194,14 +210,14 @@ setup_ECDHE grp = do usingHState ctx $ setSupportedGroup grp- (srvpri, srvpub) <- generateECDHE ctx grp+ (srvpri, srvpub) <- generateGroup ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams- usingHState ctx $ setGroupPrivate srvpri+ usingHState ctx $ setGroupPrivate [(grp, srvpri)] return serverParams generateSKX_ECDHE kxsAlg = do- let possibleECGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableECGroups+ let possibleECGroups = commonGroups `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure g : _ -> return g@@ -227,37 +243,15 @@ -> Maybe Credential -> [ExtensionRaw] -> Session- -> IO Handshake+ -> IO ServerHello makeServerHello sparams ctx usedCipher mcred chExts session = do- resuming <- usingState_ ctx isSessionResuming- srand <-- serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams+ resuming <- usingState_ ctx getTLS12SessionResuming case mcred of Just cred -> storePrivInfoServer ctx cred _ -> return () -- return a sensible error-- -- in TLS12, we need to check as well the certificates we are sending if they have in the extension- -- the necessary bits set.- secReneg <- usingState_ ctx getSecureRenegotiation- secRengExt <-- if secReneg- then do- vd <- usingState_ ctx $ do- cvd <- getVerifyData ClientRole- svd <- getVerifyData ServerRole- return $ extensionEncode $ SecureRenegotiation cvd svd- return [ExtensionRaw EID_SecureRenegotiation vd]- else return []- ems <- usingHState ctx getExtendedMainSecret- let emsExt- | ems =- let raw = extensionEncode ExtendedMainSecret- in [ExtensionRaw EID_ExtendedMainSecret raw]- | otherwise = []- protoExt <- applicationProtocol ctx chExts sparams sniExt <- do if resuming- then return []+ then return Nothing else do msni <- usingState_ ctx getClientSNI case msni of@@ -265,56 +259,77 @@ -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty.- Just _ -> return [ExtensionRaw EID_ServerName ""]- Nothing -> return []+ Just _ -> return $ Just $ toExtensionRaw $ ServerName []+ Nothing -> return Nothing++ let ecPointExt = case extensionLookup EID_EcPointFormats chExts of+ Nothing -> Nothing+ Just _ -> Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]++ alpnExt <- applicationProtocol ctx chExts sparams++ ems <- usingHState ctx getExtendedMainSecret+ let emsExt+ | 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- ticktExt- | not resuming && useTicket =- let raw = extensionEncode $ SessionTicket ""- in [ExtensionRaw EID_SessionTicket raw]- | otherwise = []+ clientTicket = isJust $ extensionLookup EID_SessionTicket chExts+ sessionTicketExt+ | 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+ -- the necessary bits set.+ secReneg <- usingState_ ctx getSecureRenegotiation+ secureRenegExt <-+ if secReneg+ then do+ vd <- usingState_ ctx $ do+ VerifyData cvd <- getVerifyData ClientRole+ VerifyData svd <- getVerifyData ServerRole+ return $ SecureRenegotiation cvd svd+ return $ Just $ toExtensionRaw vd+ else return Nothing++ recodeSizeLimitExt <- processRecordSizeLimit ctx chExts False++ srand <-+ serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams+ let shExts = sharedHelloExtensions (serverShared sparams)- ++ secRengExt- ++ emsExt- ++ protoExt- ++ sniExt- ++ ticktExt+ ++ catMaybes+ [ {- 0x00 -} sniExt+ , {- 0x0b -} ecPointExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0xff01 -} secureRenegExt+ ] usingState_ ctx $ setVersion TLS12- usingHState ctx $- setServerHelloParameters TLS12 srand usedCipher nullCompression+ setServerHelloParameters12 ctx TLS12 srand usedCipher nullCompression return $- ServerHello- TLS12- srand- session- (cipherID usedCipher)- (compressionID nullCompression)- shExts--hashAndSignaturesInCommon- :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]-hashAndSignaturesInCommon ctx chExts =- let cHashSigs = case extensionLookup EID_SignatureAlgorithms chExts- >>= extensionDecode MsgTClientHello of- -- See Section 7.4.1.4.1 of RFC 5246.- Nothing ->- [ (HashSHA1, SignatureECDSA)- , (HashSHA1, SignatureRSA)- , (HashSHA1, SignatureDSA)- ]- Just (SignatureAlgorithms sas) -> sas- sHashSigs = supportedHashSignatures $ ctxSupported ctx- in -- The values in the "signature_algorithms" extension- -- are in descending order of preference.- -- However here the algorithms are selected according- -- to server preference in 'supportedHashSignatures'.- sHashSigs `intersect` cHashSigs+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = session+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ } -negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]-negotiatedGroupsInCommon ctx chExts = case extensionLookup EID_SupportedGroups chExts- >>= extensionDecode MsgTClientHello of- Just (SupportedGroups clientGroups) ->- let serverGroups = supportedGroups (ctxSupported ctx)- in serverGroups `intersect` clientGroups- _ -> []+negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]+negotiatedGroupsInCommon serverGroups chExts =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExts+ []+ common+ where+ common (SupportedGroups clientGroups) = serverGroups `intersect` clientGroups
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -3,10 +3,10 @@ module Network.TLS.Handshake.Server.ServerHello13 ( sendServerHello13,+ sendHRR, ) where import Control.Monad.State.Strict-import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -22,10 +22,10 @@ import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters-import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -36,34 +36,54 @@ :: ServerParams -> Context -> KeyShareEntry- -> (Cipher, Hash, Bool)- -> CH+ -> (Cipher, Hash, Bool) -- rtt0+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+ -- authenticated, is0RTTvalid, ticket ALPN+ -> ClientHello+ -> Maybe ClientRandom -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret- , Bool- , Bool+ , Bool -- authenticated+ , Bool -- rtt0OK )-sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = 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+ let zlib =+ lookupAndDecode+ EID_CompressCertificate+ MsgTClientHello+ chExtensions+ False+ (\(CompressCertificate ccas) -> CCA_Zlib `elem` ccas)++ recodeSizeLimitExt <- processRecordSizeLimit ctx chExtensions True+ enableMyRecordLimit ctx+ newSession ctx >>= \ss -> usingState_ ctx $ do- setSession ss False- setClientSupportsPHA supportsPHA- usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare- srand <- setServerParameter- -- ALPN is used in choosePSK- protoExt <- applicationProtocol ctx chExtensions sparams- (psk, binderInfo, is0RTTvalid) <- choosePSK- earlyKey <- calculateEarlySecret ctx choice (Left psk) True- let earlySecret = pairBase earlyKey- clientEarlySecret = pairClient earlyKey- extensions <- checkBinder earlySecret binderInfo+ setSession ss+ setTLS13ClientSupportsPHA supportsPHA+ usingHState ctx $ do+ setSupportedGroup $ keyShareEntryGroup clientKeyShare+ setOuterClientRandom mOuterClientRandom hrr <- usingState_ ctx getTLS13HRR- let authenticated = isJust binderInfo- rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+ alpnExt <- applicationProtocol ctx chExtensions sparams+ negotiatedALPN <- usingState_ ctx getNegotiatedProtocol+ setServerParameter+ let rtt0OK =+ authenticated+ && not hrr+ && rtt0+ && rtt0accept+ && is0RTTvalid+ && ticketALPN == negotiatedALPN extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)- let allCreds =- filterCredentials (isCredentialAllowed TLS13 chExtensions) $+ let p = makeCredentialPredicate TLS13 chExtensions+ allCreds =+ filterCredentials (isCredentialAllowed TLS13 p) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) ---------------------------------------------------------------- established <- ctxEstablished ctx@@ -83,7 +103,7 @@ (ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do- sendServerHello keyShare srand extensions+ sendServerHello keyShare sendChangeCipherSpec13 ctx ---------------------------------------------------------------- handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe@@ -101,16 +121,17 @@ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret) contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo ----------------------------------------------------------------- sendExtensions rtt0OK protoExt+ liftIO $ enablePeerRecordLimit ctx+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt case mCredInfo of Nothing -> return ()- Just (cred, hashSig) -> sendCertAndVerify cred hashSig+ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs- loadPacket13 ctx $ Handshake13 [rawFinished]+ loadPacket13 ctx $ Handshake13 [rawFinished] [] return (clientHandshakeSecret, handSecret) ----------------------------------------------------------------- hChSf <- transcriptHash ctx+ hChSf <- transcriptHash ctx "CH..SF" appKey <- calculateApplicationSecret ctx choice handSecret hChSf let clientApplicationSecret0 = triClient appKey serverApplicationSecret0 = triServer appKey@@ -118,89 +139,36 @@ let appSecInfo = ApplicationSecretInfo (clientApplicationSecret0, serverApplicationSecret0) contextSync ctx $ SendServerFinished appSecInfo ----------------------------------------------------------------- if rtt0OK- then setEstablished ctx (EarlyDataAllowed rtt0max)- else- when (established == NotEstablished) $- setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ when rtt0OK $ setEstablished ctx (EarlyDataAllowed rtt0max) return (appKey, clientHandshakeSecret, authenticated, rtt0OK) where choice = makeCipherChoice TLS13 usedCipher setServerParameter = do- srand <-- serverRandom ctx TLS13 $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion TLS13- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- return srand-- supportsPHA = case extensionLookup EID_PostHandshakeAuth chExtensions- >>= extensionDecode MsgTClientHello of- Just PostHandshakeAuth -> True- Nothing -> False-- choosePSK = case extensionLookup EID_PreSharedKey chExtensions- >>= extensionDecode MsgTClientHello of- Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge : _) bnds@(bnd : _)) -> 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- msdata <-- if rtt0- then sessionResumeOnlyOnce mgr sessionId- else sessionResume mgr sessionId- 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)- _ -> return (zero, Nothing, False)+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher False - checkSessionEquality sdata = do- msni <- usingState_ ctx getClientSNI- malpn <- usingState_ ctx getNegotiatedProtocol- let isSameSNI = sessionClientSNI sdata == msni- isSameCipher = sessionCipher sdata == cipherID usedCipher- ciphers = supportedCiphers $ serverSupported sparams- isSameKDF = case find (\c -> cipherID c == sessionCipher sdata) ciphers of- 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- return (isPSKvalid, is0RTTvalid)+ supportsPHA =+ lookupAndDecode+ EID_PostHandshakeAuth+ MsgTClientHello+ chExtensions+ False+ (\PostHandshakeAuth -> True) rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams rtt0accept = serverEarlyDataSize sparams > 0 - checkBinder _ Nothing = return []- checkBinder earlySecret (Just (binder, n, tlen)) = do- binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing- unless (binder == binder') $- decryptError "PSK binder validation failed"- let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n- return [ExtensionRaw EID_PreSharedKey selectedIdentity]- decideCredentialInfo allCreds = do- cHashSigs <- case extensionLookup EID_SignatureAlgorithms chExtensions of- Nothing ->- throwCore $ Error_Protocol "no signature_algorithms extension" MissingExtension- Just sa -> case extensionDecode MsgTClientHello sa of- Nothing ->- throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError- Just (SignatureAlgorithms sas) -> return sas+ let err =+ throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError+ cHashSigs <-+ lookupAndDecodeAndDo+ EID_SignatureAlgorithms+ MsgTClientHello+ chExtensions+ err+ (\(SignatureAlgorithms sas) -> return sas) -- When deciding signature algorithm and certificate, we try to keep -- certificates supported by the client, but fallback to all credentials -- if this produces no suitable result (see RFC 5246 section 7.4.2 and@@ -215,76 +183,117 @@ mcs -> return mcs mcs -> return mcs - sendServerHello keyShare srand extensions = do- let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare- selectedVersion = extensionEncode $ SupportedVersionsServerHello TLS13- extensions' =- ExtensionRaw EID_KeyShare serverKeyShare- : ExtensionRaw EID_SupportedVersions selectedVersion- : extensions- helo = ServerHello13 srand chSession (cipherID usedCipher) extensions'- loadPacket13 ctx $ Handshake13 [helo]+ sendServerHello keyShare = do+ let keyShareExt = toExtensionRaw $ KeyShareServerHello keyShare+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ shExts = keyShareExt : versionExt : preSharedKeyExt+ if isJust mOuterClientRandom+ then do+ srand <- liftIO $ serverRandomECH ctx+ let cipherId = CipherId (cipherID usedCipher)+ sh =+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = chSession+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = shExts+ }+ suffix <- computeConfirm ctx usedHash sh "ech accept confirmation"+ let srand' = replaceServerRandomECH srand suffix+ sh' =+ SH+ { shVersion = TLS12+ , shRandom = srand'+ , shSession = chSession+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = shExts+ }+ usingHState ctx $ setECHAccepted True+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] []+ else do+ srand <-+ liftIO $+ serverRandom ctx TLS13 $+ supportedVersions $+ serverSupported sparams+ let sh =+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = chSession+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ }+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh] [] - sendCertAndVerify cred@(certChain, _) hashSig = do+ sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here.- certReq = makeCertRequest sparams ctx certReqCtx- loadPacket13 ctx $ Handshake13 [certReq]+ certReq = makeCertRequest sparams ctx certReqCtx True+ loadPacket13 ctx $ Handshake13 [certReq] [] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) []- loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess]+ let certtag = if zlib then CompressedCertificate13 else Certificate13+ loadPacket13 ctx $+ Handshake13 [certtag "" (CertificateChain_ certChain) ess] [] liftIO $ usingState_ ctx $ setServerCertificateChain certChain- hChSc <- transcriptHash ctx+ hChSc <- transcriptHash ctx "CH..SC" pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc- loadPacket13 ctx $ Handshake13 [vrfy]+ loadPacket13 ctx $ Handshake13 [vrfy] [] - sendExtensions rtt0OK protoExt = do+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do msni <- liftIO $ usingState_ ctx getClientSNI- let sniExtension = case msni of+ let sniExt = case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty.- Just _ -> Just $ ExtensionRaw EID_ServerName ""+ Just _ -> Just $ toExtensionRaw $ ServerName [] Nothing -> Nothing+ mgroup <- usingHState ctx getSupportedGroup let serverGroups = supportedGroups (ctxSupported ctx)- groupExtension- | null serverGroups = Nothing- | maybe True (== head serverGroups) mgroup = Nothing- | otherwise =- Just $- ExtensionRaw EID_SupportedGroups $- extensionEncode (SupportedGroups serverGroups)- let earlyDataExtension- | rtt0OK =+ groupExt = case serverGroups of+ [] -> Nothing+ rg : _ -> case mgroup of+ Nothing -> Nothing+ Just grp+ | grp == rg -> Nothing+ | otherwise -> Just $ toExtensionRaw $ SupportedGroups serverGroups+ let earlyDataExt+ | rtt0OK = Just $ toExtensionRaw $ EarlyDataIndication Nothing+ | otherwise = Nothing++ sendECH <- usingHState ctx getECHEE+ let echExt+ | sendECH = Just $- ExtensionRaw EID_EarlyData $- extensionEncode (EarlyDataIndication Nothing)+ toExtensionRaw $+ ECHEncryptedExtensions $+ sharedECHConfigList $+ serverShared sparams | otherwise = Nothing- let extensions =+ let eeExtensions = sharedHelloExtensions (serverShared sparams) ++ catMaybes- [ earlyDataExtension- , groupExtension- , sniExtension+ [ {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x10 -} alpnExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x2a -} earlyDataExt+ , {- 0xfe0d -} echExt ]- ++ protoExt- extensions' <-- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions- loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions']-- dhModes = case extensionLookup EID_PskKeyExchangeModes chExtensions- >>= extensionDecode MsgTClientHello of- Just (PskKeyExchangeModes ms) -> ms- Nothing -> []-- hashSize = hashDigestSize usedHash- zero = B.replicate hashSize 0+ eeExtensions' <-+ liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions+ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]@@ -309,3 +318,58 @@ contextSync :: Context -> ServerState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync _ sync -> sync ctx ctl++----------------------------------------------------------------++sendHRR :: Context -> Group -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()+sendHRR ctx g (usedCipher, usedHash, _) CH{..} isEch = do+ twice <- usingState_ ctx getTLS13HRR+ when twice $+ throwCore $+ Error_Protocol "Hello retry not allowed again" HandshakeFailure+ usingState_ ctx $ setTLS13HRR True+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher True+ hrr <- makeHRR ctx usedCipher usedHash chSession g isEch+ usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest+ runPacketFlight ctx $ do+ loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] []+ sendChangeCipherSpec13 ctx++makeHRR+ :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello+makeHRR _ usedCipher _ session g False = return hrr+ where+ keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ extensions = [keyShareExt, versionExt]+ cipherId = CipherId $ cipherID usedCipher+ hrr =+ SH+ { shVersion = TLS12+ , shRandom = hrrRandom+ , shSession = session+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = extensions+ }+makeHRR ctx usedCipher usedHash session g True = do+ suffix <- computeConfirm ctx usedHash hrr "hrr ech accept confirmation"+ let echExt' = toExtensionRaw $ ECHHelloRetryRequest suffix+ extensions' = [keyShareExt, versionExt, echExt']+ hrr' = hrr{shExtensions = extensions'}+ return hrr'+ where+ keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ echExt = toExtensionRaw $ ECHHelloRetryRequest "\x00\x00\x00\x00\x00\x00\x00\x00"+ extensions = [keyShareExt, versionExt, echExt]+ cipherId = CipherId $ cipherID usedCipher+ hrr =+ SH+ { shVersion = TLS12+ , shRandom = hrrRandom+ , shSession = session+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = extensions+ }
Network/TLS/Handshake/Server/TLS12.hs view
@@ -5,10 +5,12 @@ ) where import Control.Monad.State.Strict (gets)+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Crypto+import Network.TLS.Extension import Network.TLS.Handshake.Common import Network.TLS.Handshake.Key import Network.TLS.Handshake.Server.Common@@ -36,16 +38,22 @@ Nothing -> do recvClientCCC sparams ctx mticket <- sessionEstablished ctx+ -- RFC 5077 Section 3.3: NewSessionTicket is sent only after+ -- the session_ticket extension in ServerHello, which only a+ -- client that sent it gets.+ clientTicket <-+ maybe False (isJust . extensionLookup EID_SessionTicket . chExtensions . fst)+ <$> usingHState ctx getClientHello case mticket of- Nothing -> return ()- Just ticket -> do+ Just ticket | clientTicket -> do let life = adjustLifetime $ serverTicketLifetime sparams- sendPacket12 ctx $ Handshake [NewSessionTicket life ticket]+ sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] []+ _ -> return () sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx recvCCSandFinished ctx- handshakeDone12 ctx+ finishHandshake12 ctx where adjustLifetime i | i < 0 = 0@@ -60,6 +68,11 @@ Session (Just sessionId) -> do sessionData <- getSessionData ctx let sessionId' = B.copy sessionId+ -- SessionID method: SessionID is used as key to store+ -- SessionData. Nothing is returned.+ --+ -- Session ticket method: SessionID is ignored. SessionData+ -- is encrypted and returned. sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId'@@ -78,7 +91,7 @@ recvClientCCC :: ServerParams -> Context -> IO () recvClientCCC sparams ctx = runRecvState ctx (RecvStateHandshake expectClientCertificate) where- expectClientCertificate (Certificate certs) = do+ expectClientCertificate (Certificate (CertificateChain_ certs)) = do clientCertificate sparams ctx certs processCertificate ctx ServerRole certs @@ -86,7 +99,11 @@ -- matches our request and that we support -- verifying with that certificate. - return $ RecvStateHandshake $ expectClientKeyExchange True+ -- 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 expectClientCertificate p = expectClientKeyExchange False p -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,@@ -117,6 +134,7 @@ expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO) expectChangeCipherSpec ctx ChangeCipherSpec = do+ enableMyRecordLimit ctx return $ RecvStateHandshake $ expectFinished ctx expectChangeCipherSpec _ p = unexpected (show p) (Just "change cipher") @@ -130,15 +148,18 @@ (rver, role, random) <- usingState_ ctx $ do (,,) <$> getVersion <*> getRole <*> genRandom 48 ePreMain <- decryptRSA ctx encryptedPreMain- mainSecret <- usingHState ctx $ do- expectedVer <- gets hstClientVersion- case ePreMain of- Left _ -> setMainSecretFromPre rver role random- Right preMain -> case decodePreMainSecret preMain of- Left _ -> setMainSecretFromPre rver role random- Right (ver, _)- | ver /= expectedVer -> setMainSecretFromPre rver role random- | otherwise -> setMainSecretFromPre rver role preMain+ expectedVer <- usingHState ctx $ gets hstClientVersion+ mainSecret <- case ePreMain of+ Left _ ->+ -- BadRecordMac is nonsense but for tlsfuzzer+ throwCore $+ Error_Protocol "invalid client public key" BadRecordMac+ Right preMain -> case decodePreMainSecret $ convert preMain of+ Left _ -> usingHState ctx $ setMainSecretFromPre rver role $ convert random+ Right (ver, _)+ | ver /= expectedVer ->+ usingHState ctx $ setMainSecretFromPre rver role $ convert random+ | otherwise -> usingHState ctx $ setMainSecretFromPre rver role preMain logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion@@ -156,21 +177,23 @@ logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams- case decodeGroupPublic grp bytes of+ case groupDecodePublicB grp bytes of Left _ -> throwCore $ Error_Protocol "client public key cannot be decoded" IllegalParameter Right clipub -> do- srvpri <- usingHState ctx getGroupPrivate- case groupGetShared clipub srvpri of- Just preMain -> do- rver <- usingState_ ctx getVersion- role <- usingState_ ctx getRole- mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain- logKey ctx (MainSecret mainSecret)- Nothing ->- throwCore $- Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter+ grpSpris <- usingHState ctx getGroupPrivate+ case lookup grp grpSpris of+ Nothing -> throwCore err+ Just srvpri -> case groupDecapsulate clipub srvpri of+ Just preMain -> do+ rver <- usingState_ ctx getVersion+ role <- usingState_ ctx getRole+ mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain+ logKey ctx (MainSecret mainSecret)+ Nothing -> throwCore err+ where+ err = Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter ----------------------------------------------------------------
Network/TLS/Handshake/Server/TLS13.hs view
@@ -3,32 +3,43 @@ module Network.TLS.Handshake.Server.TLS13 ( recvClientSecondFlight13,- postHandshakeAuthServerWith,+ requestCertificateServer,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..), ) where +import qualified Control.Exception as E import Control.Monad.State.Strict+import Data.IORef import Network.TLS.Cipher import Network.TLS.Context.Internal+import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common hiding (expectFinished) import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash 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 import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types+import Network.TLS.Util import Network.TLS.X509 +----------------------------------------------------------------+ recvClientSecondFlight13 :: ServerParams -> Context@@ -37,7 +48,7 @@ , Bool , Bool )- -> CH+ -> ClientHello -> IO () recvClientSecondFlight13 sparams ctx (appKey, clientHandshakeSecret, authenticated, rtt0OK) CH{..} = do sfSentTime <- getCurrentTimeFromBase@@ -45,9 +56,15 @@ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do+ -- RFC 8446 Sec 4.4.3: Clients MUST send this message+ -- whenever authenticating via a certificate (i.e., when the+ -- Certificate message is non-empty). When sent, this message MUST+ -- appear immediately after the Certificate message and immediately+ -- prior to the Finished message. skip <- recvHandshake13 ctx $ expectCertificate sparams ctx- unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx)- recvHandshake13hash ctx expectFinished'+ unless skip $+ recvHandshake13hash ctx "CertVerify" (expectCertVerify sparams ctx)+ recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx else if rtt0OK && not (ctxQUICMode ctx)@@ -59,7 +76,7 @@ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime ] else runRecvHandshake13 $ do- recvHandshake13hash ctx expectFinished'+ recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx expectFinished@@ -70,7 +87,7 @@ -> SecretTriple ApplicationSecret -> ClientTrafficSecret HandshakeSecret -> Word64- -> ByteString+ -> TranscriptHash -> Handshake13 -> m () expectFinished sparams ctx exts appKey clientHandshakeSecret sfSentTime hChBeforeCf (Finished13 verifyData) = liftIO $ do@@ -78,7 +95,7 @@ (usedHash, usedCipher, _, _) <- getRxRecordState ctx let ClientTrafficSecret chs = clientHandshakeSecret checkFinished ctx usedHash chs hChBeforeCf verifyData- handshakeDone13 ctx+ finishHandshake13 ctx setRxRecordState ctx usedHash usedCipher clientApplicationSecret0 sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime where@@ -87,7 +104,10 @@ expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13") expectEndOfEarlyData- :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()+ :: Context+ -> ClientTrafficSecret HandshakeSecret+ -> Handshake13+ -> IO () expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do (usedHash, usedCipher, _, _) <- getRxRecordState ctx setRxRecordState ctx usedHash usedCipher clientHandshakeSecret@@ -95,13 +115,20 @@ expectCertificate :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool-expectCertificate sparams ctx (Certificate13 certCtx certs _ext) = liftIO $ do+expectCertificate sparams ctx (Certificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs return $ isNullCertificateChain certs+expectCertificate sparams ctx (CompressedCertificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do+ when (certCtx /= "") $+ throwCore $+ Error_Protocol "certificate request context MUST be empty" IllegalParameter+ -- fixme checking _ext+ clientCertificate sparams ctx certs+ return $ isNullCertificateChain certs expectCertificate _ _ hs = unexpected (show hs) (Just "certificate 13") sendNewSessionTicket@@ -115,13 +142,13 @@ sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime = when sendNST $ do cfRecvTime <- getCurrentTimeFromBase let rtt = cfRecvTime - sfSentTime- nonce <- getStateRNG ctx 32+ nonce <- TicketNonce <$> getStateRNG ctx 32 resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret let life = adjustLifetime $ serverTicketLifetime sparams psk = derivePSK choice resumptionSecret nonce (identity, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce identity rtt0max- sendPacket13 ctx $ Handshake13 [nst]+ sendPacket13 ctx $ Handshake13 [nst] [] where choice = makeCipherChoice TLS13 usedCipher rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams@@ -138,24 +165,28 @@ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk let mgr = sharedSessionManager $ serverShared sparams mticket <- sessionEstablish mgr sessionId sdata- let identity = fromMaybe sessionId mticket+ let identity = SessionIDorTicket_ $ fromMaybe sessionId mticket return (identity, ageAdd tinfo) createNewSessionTicket life add nonce identity maxSize =- NewSessionTicket13 life add nonce identity extensions+ NewSessionTicket13 life add nonce identity nstExtensions where- tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize- extensions = [ExtensionRaw EID_EarlyData tedi]+ nstExtensions+ | maxSize == 0 = []+ | otherwise = [earlyDataExt]+ where+ earlyDataExt = toExtensionRaw $ EarlyDataIndication $ Just $ fromIntegral maxSize adjustLifetime i | i < 0 = 0 | i > 604800 = 604800 | otherwise = fromIntegral i expectCertVerify- :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()-expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do+ :: MonadIO m+ => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <-- checkValidClientCertChain ctx "finished 13 message expected"+ checkValidClientCertChain ctx "invalid client certificate chain" pubkey <- case cc of [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure c : _ -> return $ certPubKey $ getCertificate c@@ -191,46 +222,178 @@ usingState_ ctx $ setClientCertificateChain certs else decryptError "verification failed" -postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do- mCertReq <- getCertRequest13 ctx certCtx- when (isNothing mCertReq) $- throwCore $- Error_Protocol "unknown certificate request context" DecodeError- let certReq = fromJust mCertReq+---------------------------------------------------------------- - -- fixme checking _ext- clientCertificate sparams ctx certs+newCertReqContext :: Context -> IO CertReqContext+newCertReqContext ctx = getStateRNG ctx 32 - baseHState <- saveHState ctx- processHandshake13 ctx certReq- processHandshake13 ctx h+requestCertificateServer :: ServerParams -> Context -> IO Bool+requestCertificateServer sparams ctx = handleEx ctx $ do+ tls13 <- tls13orLater ctx+ supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA+ let ok = tls13 && supportsPHA+ if ok+ then newIORef [] >>= sendCertReqAndRecv+ else return ok+ where+ sendCertReqAndRecv ref = do+ origCertReqCtx <- newCertReqContext ctx+ let certReq13 = makeCertRequest sparams ctx origCertReqCtx False+ _ <- withWriteLock 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+ 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)+ (finished13, _bFinished13) <- getHandshake ctx ref+ expectClientFinished ctx finished13+ void $ restoreHState ctx baseHState -- fixme+ return True +-- saving appdata and key update?+-- error handling+getHandshake+ :: Context -> IORef [Handshake13R] -> IO Handshake13R+getHandshake ctx ref = do+ hhs <- readIORef ref+ if null hhs+ then do+ ex <- recvPacket13 ctx+ either (terminate ctx) process ex+ else chk hhs+ where+ process (Handshake13 hss bss) = chk $ zip hss bss+ process _ =+ terminate ctx $+ Error_Protocol "post handshake authenticated" UnexpectedMessage+ chk [] = getHandshake ctx ref+ chk ((KeyUpdate13 mode, _) : hbs) = do+ case limitKeyUpdate $ sharedLimit $ ctxShared ctx of+ Just limit | limit > 0 -> do+ count <- incrementTLS13KeyUpdateCount ctx+ when (count > limit) $+ terminate ctx $+ Error_Protocol "too many consecutive KeyUpdate messages" UnexpectedMessage+ _ -> return ()+ keyUpdate ctx getRxRecordState setRxRecordState+ -- Write lock wraps both actions because we don't want another+ -- packet to be sent by another thread before the Tx state is+ -- updated.+ when (mode == UpdateRequested) $ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] []+ keyUpdate ctx getTxRecordState setTxRecordState+ chk hbs+ chk (hb : hbs) = do+ writeIORef ref hbs+ return hb++expectClientCertificate+ :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool+expectClientCertificate sparams ctx origCertReqCtx (Certificate13 certReqCtx (CertificateChain_ certs) _ext) = do+ expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs+ return $ isNullCertificateChain certs+expectClientCertificate sparams ctx origCertReqCtx (CompressedCertificate13 certReqCtx (CertificateChain_ certs) _ext) = do+ expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs+ return $ isNullCertificateChain certs+expectClientCertificate _ _ _ h = unexpected "Certificate" $ Just $ show h++expectClientCertificate'+ :: ServerParams+ -> Context+ -> CertReqContext+ -> CertReqContext+ -> CertificateChain+ -> IO ()+expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs = do+ when (origCertReqCtx /= certReqCtx) $+ throwCore $+ Error_Protocol "certificate context is wrong" IllegalParameter+ void $ clientCertificate sparams ctx certs++expectClientFinished :: Context -> Handshake13 -> IO ()+expectClientFinished ctx (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 - let expectFinished' hChBeforeCf (Finished13 verifyData) = do- checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData- void $ restoreHState ctx baseHState- expectFinished' _ hs = unexpected (show hs) (Just "finished 13")+terminate :: Context -> TLSError -> IO a+terminate ctx err = do+ let (level, desc) = errorToAlert err+ reason = errorToAlertMessage err+ send = sendPacket13 ctx . Alert13+ catchException (send [(level, desc)]) (\_ -> return ())+ setEOF ctx+ E.throwIO $ Terminated False reason err - -- Note: here the server could send updated NST too, however the library- -- currently has no API to handle resumption and client authentication- -- together, see discussion in #133- if isNullCertificateChain certs- then setPendingRecvActions ctx [PendingRecvActionHash False expectFinished']- else- setPendingRecvActions- ctx- [ PendingRecvActionHash False (expectCertVerify sparams ctx)- , PendingRecvActionHash False expectFinished'- ]-postHandshakeAuthServerWith _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in postHandshakeAuthServerWith"- UnexpectedMessage+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 E.fromException exception of+ Just e | Uncontextualized e' <- e -> e'+ _ -> Error_Misc (show exception)+ sendPacket13 ctx $ Alert13 [errorToAlert tlserror]+ void $ E.throwIO $ PostHandshake tlserror+ return False++----------------------------------------------------------------++keyUpdate+ :: Context+ -> (Context -> IO (Hash, Cipher, CryptLevel, Secret))+ -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())+ -> IO ()+keyUpdate ctx getState setState = do+ (usedHash, usedCipher, level, applicationSecretN) <- getState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $+ Error_Protocol+ "tried key update without application traffic secret"+ InternalError+ let applicationSecretN1 =+ hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $+ hashDigestSize usedHash+ setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)++-- | How to update keys in TLS 1.3+data KeyUpdateRequest+ = -- | Unidirectional key update+ OneWay+ | -- | Bidirectional key update (normal case)+ TwoWay+ deriving (Eq, Show)++-- | Updating application traffic secrets for TLS 1.3.+-- If this API is called for TLS 1.3, 'True' is returned.+-- Otherwise, 'False' is returned.+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
Network/TLS/Handshake/Signature.hs view
@@ -60,6 +60,25 @@ signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True signatureCompatible _ (_, _) = False +-- Whether the signature algorithm is for the type of the key, whatever+-- its other parameters.+keyTypeFits :: PubKey -> SignatureAlgorithm -> Bool+keyTypeFits (PubKeyRSA _) s =+ s+ `elem` [ SignatureRSA+ , SignatureRSApssRSAeSHA256+ , SignatureRSApssRSAeSHA384+ , SignatureRSApssRSAeSHA512+ , SignatureRSApsspssSHA256+ , SignatureRSApsspssSHA384+ , SignatureRSApsspssSHA512+ ]+keyTypeFits (PubKeyDSA _) s = s == SignatureDSA+keyTypeFits (PubKeyEC _) s = s == SignatureECDSA+keyTypeFits (PubKeyEd25519 _) s = s == SignatureEd25519+keyTypeFits (PubKeyEd448 _) s = s == SignatureEd448+keyTypeFits _ _ = False+ -- 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@@ -118,9 +137,21 @@ -> 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@(_, sigAlg) _) = do+ checkSupportedHashSignature ctx hashSigAlg+ unless (pubKey `keyTypeFits` sigAlg) $+ throwCore $+ Error_Protocol+ ("signature algorithm " ++ show hashSigAlg ++ " is for another type of key")+ IllegalParameter+ if pubKey `signatureCompatible` hashSigAlg+ then doVerify+ else return False where doVerify = prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs
Network/TLS/Handshake/State.hs view
@@ -4,7 +4,7 @@ module Network.TLS.Handshake.State ( HandshakeState (..),- HandshakeDigest (..),+ TransHashState (..), HandshakeMode13 (..), RTT0Status (..), CertReqCBdata,@@ -27,6 +27,16 @@ getGroupPrivate, -- * cert accessors+ setClientRandom,+ getClientRandom,+ setOuterClientRandom,+ getOuterClientRandom,+ setClientHello,+ getClientHello,+ setECHEE,+ getECHEE,+ setECHAccepted,+ getECHAccepted, setClientCertSent, getClientCertSent, setCertReqSent,@@ -42,11 +52,7 @@ -- * digest accessors addHandshakeMessage,- updateHandshakeDigest, getHandshakeMessages,- getHandshakeMessagesRev,- getHandshakeDigest,- foldHandshakeDigest, -- * main secret setMainSecret,@@ -54,7 +60,6 @@ -- * misc accessor getPendingCipher,- setServerHelloParameters, setExtendedMainSecret, getExtendedMainSecret, setSupportedGroup,@@ -67,12 +72,16 @@ getTLS13EarlySecret, setTLS13ResumptionSecret, getTLS13ResumptionSecret,+ setTLS13CertComp,+ getTLS13CertComp, setCCS13Sent, getCCS13Sent,+ setCCS13Recv,+ getCCS13Recv, ) where import Control.Monad.State.Strict-import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray (convert) import Data.X509 (CertificateChain) import Network.TLS.Cipher@@ -91,23 +100,37 @@ } deriving (Show) -data HandshakeDigest- = HandshakeMessages [ByteString]- | HandshakeDigestContext HashCtx- deriving (Show)+data TransHashState+ = -- | Initial state+ TransHashState0+ | -- | A raw CH is stored since hash algo is not chosen yet.+ TransHashState1 [ByteString]+ | -- | Hashed+ TransHashState2 HashCtx +{- FOURMOLU_DISABLE -}+instance Show TransHashState where+ show TransHashState0 = "State0 "+ show (TransHashState1 _) = "State1 CH"+ show (TransHashState2 hctx) = showBytesHex $ hashFinal hctx+{- FOURMOLU_ENABLE -}+ data HandshakeState = HandshakeState { hstClientVersion :: Version , hstClientRandom :: ClientRandom+ -- ^ For ECH, inner client random. , hstServerRandom :: Maybe ServerRandom- , hstMainSecret :: Maybe ByteString+ , hstMainSecret :: Maybe Secret , hstKeyState :: HandshakeKeyState , hstServerDHParams :: Maybe ServerDHParams , hstDHPrivate :: Maybe DHPrivate , hstServerECDHParams :: Maybe ServerECDHParams- , hstGroupPrivate :: Maybe GroupPrivate- , hstHandshakeDigest :: HandshakeDigest+ , hstGroupPrivate :: [(Group, GroupPrivate)]+ , hstTransHashState :: TransHashState+ , hstTransHashStateI :: TransHashState -- Inner CH for client ECH , hstHandshakeMessages :: [ByteString]+ -- ^ To create certificate verify for TLS 1.2.+ -- This should be removed when TLS 1.2 is dropped. , hstCertReqToken :: Maybe ByteString -- ^ Set to Just-value when a TLS13 certificate request is received , hstCertReqCBdata :: Maybe CertReqCBdata@@ -131,9 +154,17 @@ , hstSupportedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: RTT0Status- , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret)+ , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret)+ , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool+ , hstCCS13Recv :: Bool+ , hstTLS13OuterClientRandom :: Maybe ClientRandom+ -- ^ Used for key logging in the case of ECH.+ , hstTLS13ClientHello :: Maybe (ClientHello, [ByteString])+ -- ^ Inner client hello in the case of ECH.+ , hstTLS13ECHAccepted :: Bool+ , hstTLS13ECHEE :: Bool } deriving (Show) @@ -205,8 +236,9 @@ , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing- , hstGroupPrivate = Nothing- , hstHandshakeDigest = HandshakeMessages []+ , hstGroupPrivate = []+ , hstTransHashState = TransHashState0+ , hstTransHashStateI = TransHashState0 , hstHandshakeMessages = [] , hstCertReqToken = Nothing , hstCertReqCBdata = Nothing@@ -224,19 +256,25 @@ , hstTLS13RTT0Status = RTT0None , hstTLS13EarlySecret = Nothing , hstTLS13ResumptionSecret = Nothing+ , hstTLS13CertComp = False , hstCCS13Sent = False+ , hstCCS13Recv = False+ , hstTLS13OuterClientRandom = Nothing+ , hstTLS13ClientHello = Nothing+ , hstTLS13ECHAccepted = False+ , hstTLS13ECHEE = False } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) runHandshake hst f = runState (runHandshakeM f) hst setPublicKey :: PubKey -> HandshakeM ()-setPublicKey pk = modify (\hst -> hst{hstKeyState = setPK (hstKeyState hst)})+setPublicKey pk = modify' (\hst -> hst{hstKeyState = setPK (hstKeyState hst)}) where setPK hks = hks{hksRemotePublicKey = Just pk} setPublicPrivateKeys :: (PubKey, PrivKey) -> HandshakeM ()-setPublicPrivateKeys keys = modify (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)})+setPublicPrivateKeys keys = modify' (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)}) where setKeys hks = hks{hksLocalPublicPrivateKeys = Just keys} @@ -248,37 +286,37 @@ fromJust <$> gets (hksLocalPublicPrivateKeys . hstKeyState) setServerDHParams :: ServerDHParams -> HandshakeM ()-setServerDHParams shp = modify (\hst -> hst{hstServerDHParams = Just shp})+setServerDHParams shp = modify' (\hst -> hst{hstServerDHParams = Just shp}) getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust <$> gets hstServerDHParams setServerECDHParams :: ServerECDHParams -> HandshakeM ()-setServerECDHParams shp = modify (\hst -> hst{hstServerECDHParams = Just shp})+setServerECDHParams shp = modify' (\hst -> hst{hstServerECDHParams = Just shp}) getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust <$> gets hstServerECDHParams setDHPrivate :: DHPrivate -> HandshakeM ()-setDHPrivate shp = modify (\hst -> hst{hstDHPrivate = Just shp})+setDHPrivate shp = modify' (\hst -> hst{hstDHPrivate = Just shp}) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate -getGroupPrivate :: HandshakeM GroupPrivate-getGroupPrivate = fromJust <$> gets hstGroupPrivate+getGroupPrivate :: HandshakeM [(Group, GroupPrivate)]+getGroupPrivate = gets hstGroupPrivate -setGroupPrivate :: GroupPrivate -> HandshakeM ()-setGroupPrivate shp = modify (\hst -> hst{hstGroupPrivate = Just shp})+setGroupPrivate :: [(Group, GroupPrivate)] -> HandshakeM ()+setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = shp}) setExtendedMainSecret :: Bool -> HandshakeM ()-setExtendedMainSecret b = modify (\hst -> hst{hstExtendedMainSecret = b})+setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b}) getExtendedMainSecret :: HandshakeM Bool getExtendedMainSecret = gets hstExtendedMainSecret setSupportedGroup :: Group -> HandshakeM ()-setSupportedGroup g = modify (\hst -> hst{hstSupportedGroup = Just g})+setSupportedGroup g = modify' (\hst -> hst{hstSupportedGroup = Just g}) getSupportedGroup :: HandshakeM (Maybe Group) getSupportedGroup = gets hstSupportedGroup@@ -296,7 +334,7 @@ deriving (Show, Eq) setTLS13HandshakeMode :: HandshakeMode13 -> HandshakeM ()-setTLS13HandshakeMode s = modify (\hst -> hst{hstTLS13HandshakeMode = s})+setTLS13HandshakeMode s = modify' (\hst -> hst{hstTLS13HandshakeMode = s}) getTLS13HandshakeMode :: HandshakeM HandshakeMode13 getTLS13HandshakeMode = gets hstTLS13HandshakeMode@@ -309,64 +347,106 @@ deriving (Show, Eq) setTLS13RTT0Status :: RTT0Status -> HandshakeM ()-setTLS13RTT0Status s = modify (\hst -> hst{hstTLS13RTT0Status = s})+setTLS13RTT0Status s = modify' (\hst -> hst{hstTLS13RTT0Status = s}) getTLS13RTT0Status :: HandshakeM RTT0Status getTLS13RTT0Status = gets hstTLS13RTT0Status setTLS13EarlySecret :: BaseSecret EarlySecret -> HandshakeM ()-setTLS13EarlySecret secret = modify (\hst -> hst{hstTLS13EarlySecret = Just secret})+setTLS13EarlySecret secret = modify' (\hst -> hst{hstTLS13EarlySecret = Just secret}) getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) getTLS13EarlySecret = gets hstTLS13EarlySecret setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM ()-setTLS13ResumptionSecret secret = modify (\hst -> hst{hstTLS13ResumptionSecret = Just secret})+setTLS13ResumptionSecret secret = modify' (\hst -> hst{hstTLS13ResumptionSecret = Just secret}) getTLS13ResumptionSecret :: HandshakeM (Maybe (BaseSecret ResumptionSecret)) getTLS13ResumptionSecret = gets hstTLS13ResumptionSecret +setTLS13CertComp :: Bool -> HandshakeM ()+setTLS13CertComp comp = modify' (\hst -> hst{hstTLS13CertComp = comp})++getTLS13CertComp :: HandshakeM Bool+getTLS13CertComp = gets hstTLS13CertComp+ setCCS13Sent :: Bool -> HandshakeM ()-setCCS13Sent sent = modify (\hst -> hst{hstCCS13Sent = sent})+setCCS13Sent sent = modify' (\hst -> hst{hstCCS13Sent = sent}) getCCS13Sent :: HandshakeM Bool getCCS13Sent = gets hstCCS13Sent +setCCS13Recv :: Bool -> HandshakeM ()+setCCS13Recv sent = modify' (\hst -> hst{hstCCS13Recv = sent})++getCCS13Recv :: HandshakeM Bool+getCCS13Recv = gets hstCCS13Recv+ setCertReqSent :: Bool -> HandshakeM ()-setCertReqSent b = modify (\hst -> hst{hstCertReqSent = b})+setCertReqSent b = modify' (\hst -> hst{hstCertReqSent = b}) getCertReqSent :: HandshakeM Bool getCertReqSent = gets hstCertReqSent setClientCertSent :: Bool -> HandshakeM ()-setClientCertSent b = modify (\hst -> hst{hstClientCertSent = b})+setClientCertSent b = modify' (\hst -> hst{hstClientCertSent = b}) +getClientRandom :: HandshakeM ClientRandom+getClientRandom = gets hstClientRandom++setClientRandom :: ClientRandom -> HandshakeM ()+setClientRandom cr = modify' $ \hst -> hst{hstClientRandom = cr}++getOuterClientRandom :: HandshakeM (Maybe ClientRandom)+getOuterClientRandom = gets hstTLS13OuterClientRandom++setOuterClientRandom :: Maybe ClientRandom -> HandshakeM ()+setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr})++getClientHello :: HandshakeM (Maybe (ClientHello, [ByteString]))+getClientHello = gets hstTLS13ClientHello++setClientHello :: ClientHello -> [ByteString] -> HandshakeM ()+setClientHello ch b = modify' $ \hst -> hst{hstTLS13ClientHello = Just (ch, b)}++getECHAccepted :: HandshakeM Bool+getECHAccepted = gets hstTLS13ECHAccepted++setECHAccepted :: Bool -> HandshakeM ()+setECHAccepted b = modify' $ \hst -> hst{hstTLS13ECHAccepted = b}++getECHEE :: HandshakeM Bool+getECHEE = gets hstTLS13ECHEE++setECHEE :: Bool -> HandshakeM ()+setECHEE b = modify' $ \hst -> hst{hstTLS13ECHEE = b}+ getClientCertSent :: HandshakeM Bool getClientCertSent = gets hstClientCertSent setClientCertChain :: CertificateChain -> HandshakeM ()-setClientCertChain b = modify (\hst -> hst{hstClientCertChain = Just b})+setClientCertChain b = modify' (\hst -> hst{hstClientCertChain = Just b}) getClientCertChain :: HandshakeM (Maybe CertificateChain) getClientCertChain = gets hstClientCertChain -- setCertReqToken :: Maybe ByteString -> HandshakeM ()-setCertReqToken token = modify $ \hst -> hst{hstCertReqToken = token}+setCertReqToken token = modify' $ \hst -> hst{hstCertReqToken = token} getCertReqToken :: HandshakeM (Maybe ByteString) getCertReqToken = gets hstCertReqToken -- setCertReqCBdata :: Maybe CertReqCBdata -> HandshakeM ()-setCertReqCBdata d = modify (\hst -> hst{hstCertReqCBdata = d})+setCertReqCBdata d = modify' (\hst -> hst{hstCertReqCBdata = d}) getCertReqCBdata :: HandshakeM (Maybe CertReqCBdata) getCertReqCBdata = gets hstCertReqCBdata -- Dead code, until we find some use for the extension setCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] -> HandshakeM ()-setCertReqSigAlgsCert as = modify $ \hst -> hst{hstCertReqSigAlgsCert = as}+setCertReqSigAlgsCert as = modify' $ \hst -> hst{hstCertReqSigAlgsCert = as} getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm]) getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert@@ -376,73 +456,20 @@ getPendingCipher = fromJust <$> gets hstPendingCipher addHandshakeMessage :: ByteString -> HandshakeM ()-addHandshakeMessage content = modify $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs}+addHandshakeMessage content = modify' $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) -getHandshakeMessagesRev :: HandshakeM [ByteString]-getHandshakeMessagesRev = gets hstHandshakeMessages--updateHandshakeDigest :: ByteString -> HandshakeM ()-updateHandshakeDigest content = modify $ \hs ->- hs- { hstHandshakeDigest = case hstHandshakeDigest hs of- HandshakeMessages bytes -> HandshakeMessages (content : bytes)- HandshakeDigestContext hashCtx -> HandshakeDigestContext $ hashUpdate hashCtx content- }---- | Compress the whole transcript with the specified function. Function @f@--- takes the handshake digest as input and returns an encoded handshake message--- to replace the transcript with.-foldHandshakeDigest :: Hash -> (ByteString -> ByteString) -> HandshakeM ()-foldHandshakeDigest hashAlg f = modify $ \hs ->- case hstHandshakeDigest hs of- HandshakeMessages bytes ->- let hashCtx = foldl hashUpdate (hashInit hashAlg) $ reverse bytes- folded = f (hashFinal hashCtx)- in hs- { hstHandshakeDigest = HandshakeMessages [folded]- , hstHandshakeMessages = [folded]- }- HandshakeDigestContext hashCtx ->- let folded = f (hashFinal hashCtx)- hashCtx' = hashUpdate (hashInit hashAlg) folded- in hs- { hstHandshakeDigest = HandshakeDigestContext hashCtx'- , hstHandshakeMessages = [folded]- }--getSessionHash :: HandshakeM ByteString-getSessionHash = gets $ \hst ->- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized session hash"--getHandshakeDigest :: Version -> Role -> HandshakeM ByteString-getHandshakeDigest ver role = gets gen- where- gen hst = case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx ->- let msecret = fromJust $ hstMainSecret hst- cipher = fromJust $ hstPendingCipher hst- in generateFinished ver cipher msecret hashCtx- HandshakeMessages _ ->- error "un-initialized handshake digest"- generateFinished- | role == ClientRole = generateClientFinished- | otherwise = generateServerFinished- -- | Generate the main secret from the pre-main secret. setMainSecretFromPre- :: ByteArrayAccess preMain- => Version+ :: Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side- -> preMain+ -> Secret -- ^ the pre-main secret- -> HandshakeM ByteString+ -> HandshakeM Secret setMainSecretFromPre ver role preMainSecret = do ems <- getExtendedMainSecret secret <- if ems then get >>= genExtendedSecret else genSecret <$> get@@ -463,10 +490,16 @@ preMainSecret <$> getSessionHash +getSessionHash :: HandshakeM ByteString+getSessionHash = gets $ \hst ->+ case hstTransHashState hst of+ TransHashState2 hashCtx -> hashFinal hashCtx+ _ -> error "un-initialized session hash"+ -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state.-setMainSecret :: Version -> Role -> ByteString -> HandshakeM ()-setMainSecret ver role mainSecret = modify $ \hst ->+setMainSecret :: Version -> Role -> Secret -> HandshakeM ()+setMainSecret ver role mainSecret = modify' $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role in hst { hstMainSecret = Just mainSecret@@ -475,7 +508,7 @@ } computeKeyBlock- :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState)+ :: HandshakeState -> Secret -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust $ hstPendingCipher hst@@ -504,13 +537,13 @@ cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey- , cstIV = cWriteIV+ , cstIV = convert $ cWriteIV , cstMacSecret = cMACSecret } cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey- , cstIV = sWriteIV+ , cstIV = convert $ sWriteIV , cstMacSecret = sMACSecret } msClient = MacState{msSequence = 0}@@ -534,31 +567,3 @@ } orOnServer f g = if cc == ClientRole then f else g--setServerHelloParameters- :: Version- -- ^ chosen version- -> ServerRandom- -> Cipher- -> Compression- -> HandshakeM ()-setServerHelloParameters ver sran cipher compression = do- modify $ \hst ->- hst- { hstServerRandom = Just sran- , hstPendingCipher = Just cipher- , hstPendingCompression = compression- , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst- }- where- hashAlg = getHash ver cipher- updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"---- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384--- instead of the default SHA256.-getHash :: Version -> Cipher -> Hash-getHash ver ciph- | ver < TLS12 = SHA1_MD5- | maybe True (< TLS12) (cipherMinVer ciph) = SHA256- | otherwise = cipherHash ciph
Network/TLS/Handshake/State13.hs view
@@ -15,40 +15,32 @@ getRxLevel, clearTxRecordState, clearRxRecordState,- setHelloParameters13,- transcriptHash,- wrapAsMessageHash13, PendingRecvAction (..), setPendingRecvActions, popPendingRecvAction, ) where import Control.Concurrent.MVar-import Control.Monad.State-import qualified Data.ByteString as B import Data.IORef import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal-import Network.TLS.Crypto-import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.KeySchedule (hkdfExpandLabel) import Network.TLS.Record.State-import Network.TLS.Struct import Network.TLS.Types -getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getRxRecordState ctx = getXState ctx ctxRxRecordState getXState :: Context -> (Context -> MVar RecordState)- -> IO (Hash, Cipher, CryptLevel, ByteString)+ -> IO (Hash, Cipher, CryptLevel, Secret) getXState ctx func = do tx <- readMVar (func ctx) let usedCipher = fromJust $ stCipher tx@@ -74,7 +66,7 @@ return $ stCryptLevel tx class TrafficSecret ty where- fromTrafficSecret :: ty -> (CryptLevel, ByteString)+ fromTrafficSecret :: ty -> (CryptLevel, Secret) instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s)@@ -111,7 +103,7 @@ -> Hash -> Cipher -> CryptLevel- -> ByteString+ -> Secret -> IO () setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt)@@ -145,51 +137,6 @@ clearXState :: (Context -> MVar RecordState) -> Context -> IO () clearXState func ctx = modifyMVar_ (func ctx) (\rt -> return rt{stCipher = Nothing})--setHelloParameters13 :: Cipher -> HandshakeM (Either TLSError ())-setHelloParameters13 cipher = do- hst <- get- case hstPendingCipher hst of- Nothing -> do- put- hst- { hstPendingCipher = Just cipher- , hstPendingCompression = nullCompression- , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst- }- return $ Right ()- Just oldcipher- | cipher == oldcipher -> return $ Right ()- | otherwise ->- return $- Left $- Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter- where- hashAlg = cipherHash cipher- updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"---- When a HelloRetryRequest is sent or received, the existing transcript must be--- wrapped in a "message_hash" construct. See RFC 8446 section 4.4.1. This--- applies to key-schedule computations as well as the ones for PSK binders.-wrapAsMessageHash13 :: HandshakeM ()-wrapAsMessageHash13 = do- cipher <- getPendingCipher- foldHandshakeDigest (cipherHash cipher) foldFunc- where- foldFunc dig =- B.concat- [ "\254\0\0"- , B.singleton (fromIntegral $ B.length dig)- , dig- ]--transcriptHash :: MonadIO m => Context -> m ByteString-transcriptHash ctx = do- hst <- fromJust <$> getHState ctx- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized handshake digest" setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx)
+ Network/TLS/Handshake/TranscriptHash.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.TranscriptHash (+ transcriptHash,+ transcriptHashWith,+ transitTranscriptHashI,+ updateTranscriptHash,+ updateTranscriptHashI,+ transitTranscriptHash,+ copyTranscriptHash,+ TranscriptHash (..),+) where++import Control.Monad.State+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Crypto+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Types++----------------------------------------------------------------++transitTranscriptHash :: Context -> String -> Hash -> Bool -> IO ()+transitTranscriptHash ctx label hashAlg isHRR = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashState = transit label hashAlg isHRR $ hstTransHashState hst}+ traceTranscriptHash ctx label hstTransHashState++transitTranscriptHashI :: Context -> String -> Hash -> Bool -> IO ()+transitTranscriptHashI ctx label hashAlg isHRR = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashStateI = transit label hashAlg isHRR $ hstTransHashStateI hst}+ traceTranscriptHash ctx label hstTransHashStateI++transit :: String -> Hash -> Bool -> TransHashState -> TransHashState+transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0+transit _ _ _ st2@(TransHashState2 _) = st2+transit _ hashAlg isHRR (TransHashState1 chs)+ | isHRR = TransHashState2 $ hashUpdate (hashInit hashAlg) hsMsg+ | otherwise = TransHashState2 $ hashUpdates (hashInit hashAlg) ch+ where+ ch = reverse chs+ hsMsg =+ -- Handshake message:+ -- typ <-len-> body+ -- 254 0 0 len hash(CH1)+ B.concat+ [ "\254\0\0"+ , B.singleton len+ , hashedCH+ ]+ where+ hashedCH = hashChunks hashAlg ch+ len = fromIntegral $ B.length hashedCH++----------------------------------------------------------------++updateTranscriptHash :: Context -> String -> ByteString -> IO ()+updateTranscriptHash ctx label eh = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashState = update eh label $ hstTransHashState hst}+ traceTranscriptHash ctx label hstTransHashState++updateTranscriptHashI :: Context -> String -> ByteString -> IO ()+updateTranscriptHashI ctx label eh = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashStateI = update eh label $ hstTransHashStateI hst}+ traceTranscriptHash ctx label hstTransHashStateI++update :: ByteString -> String -> TransHashState -> TransHashState+update eh _ TransHashState0 = TransHashState1 [eh]+update eh _ (TransHashState1 bss) = TransHashState1 (eh : bss)+update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh++----------------------------------------------------------------++transcriptHash :: MonadIO m => Context -> String -> m TranscriptHash+transcriptHash ctx label = do+ hst <- fromJust <$> getHState ctx+ let th = calc label $ hstTransHashState hst+ liftIO $ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ showBytesHex th+ return $ TranscriptHash th++calc :: String -> TransHashState -> ByteString+calc _ (TransHashState2 hashCtx) = hashFinal hashCtx+calc label st = error $ "transcriptHash " ++ label ++ " " ++ show st++----------------------------------------------------------------++transcriptHashWith+ :: MonadIO m => Context -> String -> ByteString -> m TranscriptHash+transcriptHashWith ctx label bs = do+ role <- liftIO $ usingState_ ctx getRole+ let isClient = role == ClientRole+ hst <- fromJust <$> getHState ctx+ let st+ | isClient = hstTransHashStateI hst+ | otherwise = hstTransHashState hst+ let th = calcWith bs label st+ liftIO $ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ showBytesHex th+ return $ TranscriptHash th++calcWith :: ByteString -> String -> TransHashState -> ByteString+calcWith bs _ (TransHashState2 hashCtx) = hashFinal $ hashUpdate hashCtx bs+calcWith _ label st = error $ "transcriptHashWith " ++ label ++ " " ++ show st++----------------------------------------------------------------++copyTranscriptHash :: Context -> String -> IO ()+copyTranscriptHash ctx label = do+ usingHState ctx $ modify' $ \hst ->+ hst+ { hstTransHashState = hstTransHashStateI hst+ }+ traceTranscriptHash ctx label hstTransHashState++----------------------------------------------------------------++traceTranscriptHash+ :: Context -> String -> (HandshakeState -> TransHashState) -> IO ()+traceTranscriptHash ctx label getField = do+ hst <- fromJust <$> getHState ctx+ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ show (getField hst)++adjustLabel :: String -> String+adjustLabel label = take 24 (label ++ " ")
+ Network/TLS/HashAndSignature.hs view
@@ -0,0 +1,181 @@+{-# 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/Hooks.hs view
@@ -1,11 +1,13 @@ module Network.TLS.Hooks ( Logging (..),+ defaultLogging, Hooks (..), defaultHooks, ) where -import qualified Data.ByteString as B-import Data.Default.Class+import Data.Default (Default (def))++import Network.TLS.Imports import Network.TLS.Struct (Handshake, Header) import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain)@@ -16,8 +18,8 @@ data Logging = Logging { loggingPacketSent :: String -> IO () , loggingPacketRecv :: String -> IO ()- , loggingIOSent :: B.ByteString -> IO ()- , loggingIORecv :: Header -> B.ByteString -> IO ()+ , loggingIOSent :: ByteString -> IO ()+ , loggingIORecv :: Header -> ByteString -> IO () } defaultLogging :: Logging
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@@ -24,10 +24,11 @@ import Network.TLS.Context.Internal import Network.TLS.Hooks+import Network.TLS.IO.Decode+import Network.TLS.IO.Encode import Network.TLS.Imports-import Network.TLS.Receiving+import Network.TLS.Parameters import Network.TLS.Record-import Network.TLS.Sending import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -37,9 +38,10 @@ -- | Send one packet to the context sendPacket12 :: Context -> Packet -> IO () sendPacket12 ctx@Context{ctxRecordLayer = recordLayer} pkt = do- -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed- -- by an attacker. Hence, an empty packet is sent before a normal data packet, to- -- prevent guessability.+ -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue+ -- as IV, which can be guessed by an attacker. Hence, an empty+ -- packet is sent before a normal data packet, to prevent+ -- guessability. when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $@@ -85,96 +87,153 @@ -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket12 :: Context -> IO (Either TLSError Packet)-recvPacket12 ctx@Context{ctxRecordLayer = recordLayer} = do- hrr <- usingState_ ctx getTLS13HRR- -- When a client sends 0-RTT data to a server which rejects and sends a HRR,- -- the server will not decrypt AppData segments. The server needs to accept- -- AppData with maximum size 2^14 + 256. In all other scenarios and record- -- types the maximum size is 2^14.- let appDataOverhead = if hrr then 256 else 0- erecord <- recordRecv recordLayer ctx appDataOverhead- case erecord of- Left err -> return $ Left err- Right record ->- if hrr && isCCS record- then recvPacket12 ctx- else do- pktRecv <- processPacket ctx record+recvPacket12 ctx@Context{ctxRecordLayer = recordLayer} = loop 0+ where+ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx+ loop count+ | count > lim = do+ let err = Error_Packet "too many handshake fragment"+ logPacket ctx $ show err+ return $ Left err+ loop count = do+ hrr <- usingState_ ctx getTLS13HRR+ erecord <- recordRecv12 recordLayer ctx+ case erecord of+ Left err -> do+ logPacket ctx $ show err+ return $ Left err+ 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- then -- When a handshake record is fragmented we continue- -- receiving in order to feed stHandshakeRecordCont- recvPacket12 ctx- else do- pkt <- case pktRecv of- Right (Handshake hss) ->- ctxWithHooks ctx $ \hooks ->- Right . Handshake <$> mapM (hookRecvHandshake hooks) hss- _ -> return pktRecv- case pkt of- Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p- _ -> return ()- return pkt+ then do+ logPacket ctx "Handshake fragment"+ -- When a handshake record is fragmented+ -- we continue receiving in order to feed+ -- stHandshakeRecordCont+ loop (count + 1)+ else case pktRecv of+ Right (Handshake hss bss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+ hss' <- mapM (hookRecvHandshake hooks) hss+ return $ Right $ Handshake hss' bss+ logPacket ctx $ show pkt+ return pktRecv'+ Right pkt -> do+ logPacket ctx $ show pkt+ return pktRecv+ Left err -> do+ logPacket ctx $ show err+ return pktRecv isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool-isEmptyHandshake (Right (Handshake [])) = True+isEmptyHandshake (Right (Handshake [] _)) = True isEmptyHandshake _ = False +logPacket :: Context -> String -> IO ()+logPacket ctx msg = withLog ctx $ \logging -> loggingPacketRecv logging msg+ ---------------------------------------------------------------- recvPacket13 :: Context -> IO (Either TLSError Packet13)-recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = 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.- established <- ctxEstablished ctx- case established of- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvPacket13 ctx- _ -> return $ Left err- Left err -> return $ Left err- Right record -> do- pktRecv <- processPacket13 ctx record- if isEmptyHandshake13 pktRecv- then -- When a handshake record is fragmented we continue receiving- -- in order to feed stHandshakeRecordCont13- recvPacket13 ctx- else do- pkt <- case pktRecv of- Right (Handshake13 hss) ->- ctxWithHooks ctx $ \hooks ->- Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss- _ -> return pktRecv- case pkt of- Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p- _ -> return ()- return pkt+recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = loop 0+ where+ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx+ loop count+ | count > lim =+ return $ Left $ Error_Packet "too many handshake fragment"+ 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+ Right record -> do+ pktRecv <- decodePacket13 ctx record+ if isEmptyHandshake13 pktRecv+ then do+ logPacket ctx "Handshake fragment"+ -- When a handshake record is fragmented we+ -- continue receiving in order to feed+ -- stHandshakeRecordCont13+ loop (count + 1)+ else do+ case pktRecv of+ Right (Handshake13 hss bss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+ hss' <- mapM (hookRecvHandshake13 hooks) hss+ return $ Right $ Handshake13 hss' bss+ logPacket ctx $ show pkt+ return pktRecv'+ Right pkt@(AppData13 _) -> do+ logPacket ctx $ show pkt+ checkNotInterleaved ctx pktRecv+ Right pkt -> do+ logPacket ctx $ show pkt+ return pktRecv+ Left err -> do+ logPacket ctx $ show err+ return pktRecv isEmptyHandshake13 :: Either TLSError Packet13 -> Bool-isEmptyHandshake13 (Right (Handshake13 [])) = True+isEmptyHandshake13 (Right (Handshake13 [] _)) = True isEmptyHandshake13 _ = False ---------------------------------------------------------------- +-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with+-- other record types. Application data that arrives while a handshake+-- message is still incomplete is refused with unexpected_message rather+-- than delivered. TLS 1.3 only: RFC 5246 Section 6.2.1 lets TLS 1.2+-- interleave data of different content types.+checkNotInterleaved :: Context -> Either TLSError a -> IO (Either TLSError a)+checkNotInterleaved ctx pktRecv = do+ complete <- isRecvComplete ctx+ if complete+ then return pktRecv+ else do+ let err =+ Error_Packet_unexpected+ "application data"+ " expected: the rest of a handshake message"+ logPacket ctx $ show err+ return $ Left err+ isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do- cont <- gets stHandshakeRecordCont+ cont12 <- gets stHandshakeRecordCont12 cont13 <- gets stHandshakeRecordCont13- return $ isNothing cont && isNothing cont13+ return $ isNothing (fst cont12) && isNothing (fst cont13) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx- when (established == NotEstablished) $ throwIO ConnectionNotEstablished+ when (established == NotEstablished) $ E.throwIO ConnectionNotEstablished eofed <- ctxEOF ctx- when eofed $ throwIO $ PostHandshake Error_EOF+ when eofed $ E.throwIO $ PostHandshake Error_EOF ---------------------------------------------------------------- @@ -192,7 +251,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 ()@@ -206,4 +266,4 @@ (recordLayer, ref) <- ask liftIO $ do bs <- writePacketBytes13 ctx recordLayer pkt- modifyIORef ref (. (bs :))+ modifyIORef' ref (. (bs :))
+ Network/TLS/IO/Decode.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.IO.Decode (+ decodePacket12,+ decodePacket13,+ checkChangeCipherSpec,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as BS++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.ErrT+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Record+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++decodePacket12 :: Context -> Record Plaintext -> IO (Either TLSError Packet)+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 checkChangeCipherSpec fragment of+ Left err -> return $ Left err+ Right _ -> do+ -- 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).+ mhs <- getHState ctx+ (mCont, _) <- usingState_ ctx $ gets stHandshakeRecordCont12+ if isNothing mhs || isJust mCont+ then+ return $+ Left $+ Error_Packet_unexpected "ChangeCipherSpec" " expected: handshake"+ else do+ switchRxEncryption ctx+ return $ Right ChangeCipherSpec+decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do+ 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 decode mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake hss bss+ where+ 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 decode ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))]+ GotSuccessRemaining (ty, content) left ->+ case decode ty content of+ Left err -> throwError err+ Right h -> do+ hbs <- parseMany decode Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket12 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty++switchRxEncryption :: Context -> IO ()+switchRxEncryption ctx =+ usingHState ctx (gets hstPendingRxState) >>= \rx ->+ modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx)++----------------------------------------------------------------++decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)+decodePacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) =+ 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 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do+ (mCont, wirebytes) <- gets stHandshakeRecordCont13+ modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])})+ (hss, bss) <- unzip <$> parseMany mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake13 hss bss+ where+ parseMany mCont wirebytes bs =+ case fromMaybe decodeHandshakeRecord13 mCont bs of+ GotError err -> throwError err+ GotPartial cont -> do+ modify' (\st -> st{stHandshakeRecordCont13 = (Just cont, bs : wirebytes)})+ return []+ GotSuccess (ty, content) ->+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))]+ GotSuccessRemaining (ty, content) left ->+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right h -> do+ hbs <- parseMany Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket13 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty++-- RFC 8446 Section 5: a record of an unexpected type, including the inner+-- type of a TLS 1.3 record, is answered with unexpected_message.+unknownProtocolType :: ProtocolType -> TLSError+unknownProtocolType ty = Error_Packet_unexpected (show ty) " expected: TLS record type"++-- | A ChangeCipherSpec is the single byte 1. RFC 8446 Section 5 answers any+-- other value with unexpected_message, and TLS 1.2, which does not say,+-- is answered the same way: a record of two of them included.+checkChangeCipherSpec :: Fragment a -> Either TLSError ()+checkChangeCipherSpec fragment =+ case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left _ ->+ Left $+ Error_Packet_unexpected "ChangeCipherSpec" " expected: the single byte 1"+ Right _ -> Right ()
+ Network/TLS/IO/Encode.hs view
@@ -0,0 +1,148 @@+module Network.TLS.IO.Encode (+ encodePacket12,+ encodePacket13,+ updateTranscriptHash12,+ encodeUpdateTranscriptHash12,+ updateTranscriptHash13,+ encodeUpdateTranscriptHash13,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B+import Data.IORef++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Handshake.State+import Network.TLS.Handshake.TranscriptHash+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Parameters+import Network.TLS.Record+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types (Role (..))+import Network.TLS.Util++-- | encodePacket transform a packet into marshalled data related to current state+-- and updating state on the go+encodePacket12+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet+ -> IO (Either TLSError bytes)+encodePacket12 ctx recordLayer pkt = do+ (ver, _) <- decideRecordVersion ctx+ let pt = packetType pkt+ mkRecord bs = Record pt ver (fragmentPlaintext bs)+ mlen <- getPeerRecordLimit ctx+ records <- map mkRecord <$> packetToFragments12 ctx mlen pkt+ bs <- fmap mconcat <$> forEitherM records (recordEncode12 recordLayer ctx)+ when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx+ return bs++-- Decompose handshake packets into fragments of the specified length. AppData+-- packets are not fragmented here but by callers of sendPacket, so that the+-- empty-packet countermeasure may be applied to each fragment independently.+packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]+packetToFragments12 ctx mlen (Handshake hss _) =+ getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash12 ctx) hss+packetToFragments12 _ _ (Alert a) = return [encodeAlerts a]+packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]+packetToFragments12 _ _ (AppData x) = return [x]++switchTxEncryption :: Context -> IO ()+switchTxEncryption ctx = do+ tx <- usingHState ctx (fromJust <$> gets hstPendingTxState)+ (ver, role) <- usingState_ ctx $ do+ v <- getVersion+ r <- getRole+ return (v, r)+ liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx)+ -- set empty packet counter measure if condition are met+ when+ ( ver <= TLS10+ && role == ClientRole+ && isCBC tx+ && supportedEmptyPacket (ctxSupported ctx)+ )+ $ liftIO+ $ writeIORef (ctxNeedEmptyPacket ctx) True+ where+ isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)++encodeUpdateTranscriptHash12 :: Context -> Handshake -> IO ByteString+encodeUpdateTranscriptHash12 ctx hs = do+ when (certVerifyHandshakeMaterial hs) $+ usingHState ctx $+ addHandshakeMessage encoded+ let label = show $ typeOfHandshake hs+ when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded+ when (isClientHello hs) $ do+ usingHState ctx $ do+ (ch, b) <- fromJust <$> getClientHello+ when (null b) $ setClientHello ch [encoded]+ return encoded+ where+ encoded = encodeHandshake hs+ isClientHello (ClientHello _) = True+ isClientHello _ = False++updateTranscriptHash12 :: Context -> HandshakeR -> IO ()+updateTranscriptHash12 ctx (hs, bss) = do+ when (certVerifyHandshakeMaterial hs) $+ usingHState ctx $+ mapM_ addHandshakeMessage bss+ let label = show $ typeOfHandshake hs+ when (finishedHandshakeMaterial hs) $ do+ mapM_ (updateTranscriptHash ctx label) bss++----------------------------------------------------------------++encodePacket13+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet13+ -> IO (Either TLSError bytes)+encodePacket13 ctx recordLayer pkt = do+ let pt = contentType pkt+ mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)+ mlen <- getPeerRecordLimit ctx+ records <- map mkRecord <$> packetToFragments13 ctx mlen pkt+ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)++packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]+packetToFragments13 ctx mlen (Handshake13 hss _) =+ getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash13 ctx) hss+packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]+packetToFragments13 _ _ (AppData13 x) = return [x]+packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]++encodeUpdateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString+encodeUpdateTranscriptHash13 ctx hs+ | isIgnored hs = return encoded+ | otherwise = do+ let label = show $ typeOfHandshake13 hs+ updateTranscriptHash ctx label encoded+ usingHState ctx $ addHandshakeMessage encoded+ return encoded+ where+ encoded = encodeHandshake13 hs++updateTranscriptHash13 :: Context -> Handshake13R -> IO ()+updateTranscriptHash13 ctx (hs, bss)+ | isIgnored hs = return ()+ | otherwise = do+ let label = show $ typeOfHandshake13 hs+ mapM_ (updateTranscriptHash ctx label) bss+ usingHState ctx $ mapM_ addHandshakeMessage bss++isIgnored :: Handshake13 -> Bool+isIgnored NewSessionTicket13{} = True+isIgnored KeyUpdate13{} = True+isIgnored _ = False
Network/TLS/Imports.hs view
@@ -16,22 +16,18 @@ showBytesHex, ) where -import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()---- instance-import Data.Functor- import Control.Applicative import Control.Monad import Data.Bits+import Data.ByteArray.Encoding as B+import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Functor import Data.List import Data.Maybe import Data.Ord import Data.Semigroup import Data.Word--import Data.ByteArray.Encoding as B import qualified Prelude as P showBytesHex :: ByteString -> P.String
Network/TLS/Internal.hs view
@@ -1,24 +1,37 @@ {-# OPTIONS_HADDOCK hide #-} module Network.TLS.Internal (- module Network.TLS.Struct,- module Network.TLS.Struct13,+ module Network.TLS.Extension,+ module Network.TLS.IO.Decode,+ module Network.TLS.IO.Encode, module Network.TLS.Packet, module Network.TLS.Packet13,- module Network.TLS.Receiving,- module Network.TLS.Sending,+ module Network.TLS.Struct,+ module Network.TLS.Struct13, module Network.TLS.Types, module Network.TLS.Wire,+ module Network.TLS.X509, sendPacket12, recvPacket12,+ makeCipherShowPretty, ) where +import Data.IORef+ import Network.TLS.Core (recvPacket12, sendPacket12)+import Network.TLS.Extension+import Network.TLS.Extra.Cipher+import Network.TLS.IO.Decode+import Network.TLS.IO.Encode import Network.TLS.Packet import Network.TLS.Packet13-import Network.TLS.Receiving-import Network.TLS.Sending import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire+import Network.TLS.X509 hiding (Certificate)++----------------------------------------------------------------++makeCipherShowPretty :: IO ()+makeCipherShowPretty = writeIORef globalCipherDict ciphersuite_all
Network/TLS/KeySchedule.hs view
@@ -8,17 +8,20 @@ import qualified Crypto.Hash as H import Crypto.KDF.HKDF-import Data.ByteArray (convert)+import Data.ByteArray (ByteArray, ByteArrayAccess, convert) import qualified Data.ByteString as BS+ import Network.TLS.Crypto import Network.TLS.Imports+import Network.TLS.Types import Network.TLS.Wire ---------------------------------------------------------------- -- | @HKDF-Extract@ function. Returns the pseudorandom key (PRK) from salt and -- input keying material (IKM).-hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString+hkdfExtract+ :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba -> ba hkdfExtract SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) hkdfExtract SHA256 salt ikm = convert (extract salt ikm :: PRK H.SHA256) hkdfExtract SHA384 salt ikm = convert (extract salt ikm :: PRK H.SHA384)@@ -27,8 +30,8 @@ ---------------------------------------------------------------- -deriveSecret :: Hash -> ByteString -> ByteString -> ByteString -> ByteString-deriveSecret h secret label hashedMsgs =+deriveSecret :: Hash -> Secret -> ByteString -> TranscriptHash -> Secret+deriveSecret h secret label (TranscriptHash hashedMsgs) = hkdfExpandLabel h secret label hashedMsgs outlen where outlen = hashDigestSize h@@ -38,12 +41,13 @@ -- | @HKDF-Expand-Label@ function. Returns output keying material of the -- specified length from the PRK, customized for a TLS label and context. hkdfExpandLabel- :: Hash- -> ByteString+ :: (ByteArray ba, ByteArrayAccess ba)+ => Hash+ -> Secret -> ByteString -> ByteString -> Int- -> ByteString+ -> ba hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do@@ -51,7 +55,8 @@ putOpaque8 ("tls13 " `BS.append` label) putOpaque8 ctx -expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString+expand'+ :: (ByteArray ba, ByteArrayAccess ba) => Hash -> Secret -> ByteString -> Int -> ba expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len expand' SHA256 secret label len = expand (extractSkip secret :: PRK H.SHA256) label len expand' SHA384 secret label len = expand (extractSkip secret :: PRK H.SHA384) label len
Network/TLS/MAC.hs view
@@ -6,23 +6,25 @@ prf_SHA256, prf_TLS, prf_MD5SHA1,+ PRF, ) where -import qualified Data.ByteArray as B (xor)-import qualified Data.ByteString as B+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as BA+ import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types -type HMAC = ByteString -> ByteString -> ByteString+type HMAC = Secret -> ByteString -> Secret macSSL :: Hash -> HMAC macSSL alg secret msg = f $- B.concat+ BA.concat [ secret- , B.replicate padLen 0x5c- , f $ B.concat [secret, B.replicate padLen 0x36, msg]+ , BA.replicate padLen 0x5c+ , f $ BA.concat [secret, BA.replicate padLen 0x36, BA.convert msg] ] where padLen = case alg of@@ -31,49 +33,51 @@ _ -> error ("internal error: macSSL called with " ++ show alg) f = hash alg -hmac :: Hash -> HMAC-hmac alg secret msg = f $ B.append opad (f $ B.append ipad msg)+hmac :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ByteString -> ba+hmac alg secret msg = f $ BA.append opad (f $ BA.append ipad $ BA.convert msg) where- opad = B.map (xor 0x5c) k'- ipad = B.map (xor 0x36) k'+ opad = BA.map (0x5c `xor`) k'+ ipad = BA.map (0x36 `xor`) k' f = hash alg bl = hashBlockSize alg - k' = B.append kt pad+ k' = BA.append kt pad where- kt = if B.length secret > fromIntegral bl then f secret else secret- pad = B.replicate (fromIntegral bl - B.length kt) 0+ kt = if BA.length secret > fromIntegral bl then f secret else secret+ pad = BA.replicate (fromIntegral bl - BA.length kt) 0 hmacIter- :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString]+ :: HMAC -> Secret -> ByteString -> ByteString -> Int -> [Secret] hmacIter f secret seed aprev len = let an = f secret aprev- in let out = f secret (B.concat [an, seed])- in let digestsize = B.length out+ in let out = f secret (BA.concat [an, BA.convert seed])+ in let digestsize = BA.length out in if digestsize >= len- then [B.take (fromIntegral len) out]- else out : hmacIter f secret seed an (len - digestsize)+ then [BA.take (fromIntegral len) out]+ else out : hmacIter f secret seed (BA.convert an) (len - digestsize) -prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len+type PRF = Secret -> ByteString -> Int -> Secret -prf_MD5 :: ByteString -> ByteString -> Int -> ByteString-prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len+prf_SHA1 :: PRF+prf_SHA1 secret seed len = BA.concat $ hmacIter (hmac SHA1) secret seed seed len -prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString+prf_MD5 :: PRF+prf_MD5 secret seed len = BA.concat $ hmacIter (hmac MD5) secret seed seed len++prf_MD5SHA1 :: PRF prf_MD5SHA1 secret seed len =- B.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+ BA.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) where- slen = B.length secret- s1 = B.take (slen `div` 2 + slen `mod` 2) secret- s2 = B.drop (slen `div` 2) secret+ slen = BA.length secret+ s1 = BA.take (slen `div` 2 + slen `mod` 2) secret+ s2 = BA.drop (slen `div` 2) secret -prf_SHA256 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA256 secret seed len = B.concat $ hmacIter (hmac SHA256) secret seed seed len+prf_SHA256 :: PRF+prf_SHA256 secret seed len = BA.concat $ hmacIter (hmac SHA256) secret seed seed len -- | For now we ignore the version, but perhaps some day the PRF will depend -- not only on the cipher PRF algorithm, but also on the protocol version.-prf_TLS :: Version -> Hash -> ByteString -> ByteString -> Int -> ByteString+prf_TLS :: Version -> Hash -> PRF prf_TLS _ halg secret seed len =- B.concat $ hmacIter (hmac halg) secret seed seed len+ BA.concat $ hmacIter (hmac halg) secret seed seed len
Network/TLS/Packet.hs view
@@ -21,7 +21,9 @@ decodeHandshakeRecord, decodeHandshake, encodeHandshake,+ encodeHandshake', encodeCertificate,+ decodeClientHello', -- * marshall functions for change cipher spec message decodeChangeCipherSpec,@@ -36,8 +38,6 @@ generateMainSecret, generateExtendedMainSecret, generateKeyBlock,- generateClientFinished,- generateServerFinished, -- * for extensions parsing getSignatureHashAlgorithm,@@ -55,10 +55,13 @@ putDNames, getDNames, getHandshakeType,++ -- * PRF+ PRF,+ getPRF, ) where -import Data.ByteArray (ByteArrayAccess)-import qualified Data.ByteArray as B (convert)+import Data.ByteArray (ByteArrayAccess, convert) import qualified Data.ByteString as B import Data.X509 ( CertificateChain,@@ -66,14 +69,19 @@ decodeCertificateChain, encodeCertificateChain, )-import Network.TLS.Cipher (Cipher (..), CipherKeyExchangeType (..))+ import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.MAC import Network.TLS.Struct+import Network.TLS.Types import Network.TLS.Util.ASN1+import Network.TLS.Util.Serialization (os2ip) import Network.TLS.Wire +----------------------------------------------------------------+-- Header+ data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version@@ -82,7 +90,7 @@ } deriving (Show, Eq) -{- marshall helpers -}+-- marshall helpers getBinaryVersion :: Get Version getBinaryVersion = Version <$> getWord16 @@ -98,9 +106,7 @@ getHandshakeType :: Get HandshakeType getHandshakeType = HandshakeType <$> getWord8 -{-- - decode and encode headers- -}+-- decode and encode headers decodeHeader :: ByteString -> Either TLSError Header decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getBinaryVersion <*> getWord16@@ -108,11 +114,24 @@ encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) -{- FIXME check len <= 2^14 -}+-- FIXME check len <= 2^14 -{-- - decode and encode ALERT- -}+------------------------------------------------------------+-- CCS++decodeChangeCipherSpec :: ByteString -> Either TLSError ()+decodeChangeCipherSpec = runGetErr "changecipherspec" $ do+ x <- getWord8+ when (x /= 1) $ fail "unknown change cipher spec content"+ len <- remaining+ when (len /= 0) $ fail "the length of CSS must be 1"++encodeChangeCipherSpec :: ByteString+encodeChangeCipherSpec = runPut (putWord8 1)++----------------------------------------------------------------+-- Alert+ decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do al <- AlertLevel <$> getWord8@@ -133,66 +152,119 @@ where encodeAlert (al, ad) = putWord8 (fromAlertLevel al) >> putWord8 (fromAlertDescription ad) -{- decode and encode HANDSHAKE -}+----------------------------------------------------------------+-- decode HANDSHAKE+ 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- HandshakeType_ServerHello -> decodeServerHello- HandshakeType_Certificate -> decodeCertificate- HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp- HandshakeType_CertRequest -> decodeCertRequest cp- HandshakeType_ServerHelloDone -> decodeServerHelloDone- HandshakeType_CertVerify -> decodeCertVerify cp- HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp- HandshakeType_Finished -> decodeFinished+ HandshakeType_HelloRequest -> decodeHelloRequest+ HandshakeType_ClientHello -> decodeClientHello False+ HandshakeType_ServerHello -> decodeServerHello HandshakeType_NewSessionTicket -> decodeNewSessionTicket+ HandshakeType_Certificate -> decodeCertificate+ HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp+ HandshakeType_CertRequest -> decodeCertRequest cp+ HandshakeType_ServerHelloDone -> decodeServerHelloDone+ HandshakeType_CertVerify -> decodeCertVerify cp+ HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp+ HandshakeType_Finished -> decodeFinished x -> fail $ "Unsupported HandshakeType " ++ show x+{- FOURMOLU_ENABLE -} decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest -decodeClientHello :: Get Handshake-decodeClientHello = do+decodeClientHello' :: ByteString -> Either TLSError Handshake+decodeClientHello' = runGetErr "decodeClientHello'" $ decodeClientHello True++decodeClientHello :: Bool -> Get Handshake+decodeClientHello inner = do ver <- getBinaryVersion random <- getClientRandom32 session <- getSession- ciphers <- getWords16+ ciphers <- map CipherId <$> getWords16 compressions <- getWords8 r <- remaining exts <- if r > 0- then fromIntegral <$> getWord16 >>= getExtensions- else do- rest <- remaining- _ <- getBytes rest- return []- let ch = CH session ciphers exts- return $ ClientHello ver random compressions ch+ then getWord16 >>= getExtensions . fromIntegral+ else return []+ r1 <- remaining+ if inner+ then+ checkAndSkip r1+ else when (r1 /= 0) $ fail "Client hello has garbage"+ return $+ ClientHello $+ CH+ { chVersion = ver+ , chRandom = random+ , chSession = session+ , chCiphers = ciphers+ , chComps = compressions+ , chExtensions = exts+ }+ where+ checkAndSkip 0 = return ()+ checkAndSkip r = do+ zero <- getWord8+ when (zero /= 0) $ fail "Inner client hello has garbage"+ checkAndSkip (r - 1) decodeServerHello :: Get Handshake decodeServerHello = do ver <- getBinaryVersion random <- getServerRandom32 session <- getSession- cipherid <- getWord16+ cipherid <- CipherId <$> getWord16 compressionid <- getWord8 r <- remaining exts <- if r > 0- then fromIntegral <$> getWord16 >>= getExtensions+ then getWord16 >>= getExtensions . fromIntegral else return []- return $ ServerHello ver random session cipherid compressionid exts+ return $+ ServerHello $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = compressionid+ , shExtensions = exts+ } -decodeServerHelloDone :: Get Handshake-decodeServerHelloDone = return ServerHelloDone+decodeNewSessionTicket :: Get Handshake+decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16 decodeCertificate :: Get Handshake decodeCertificate = do@@ -201,71 +273,17 @@ <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s)- Right cc -> return $ Certificate cc+ Right cc -> return $ Certificate $ CertificateChain_ cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) -decodeFinished :: Get Handshake-decodeFinished = Finished <$> (remaining >>= getBytes)--decodeNewSessionTicket :: Get Handshake-decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16--decodeCertRequest :: CurrentParams -> Get Handshake-decodeCertRequest _cp = do- certTypes <- map CertificateType <$> getWords8- sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms- CertRequest certTypes sigHashAlgs <$> getDNames- where- getSignatureHashAlgorithms len =- getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))---- | Decode a list CA distinguished names-getDNames :: Get [DistinguishedName]-getDNames = do- dNameLen <- getWord16- -- FIXME: Decide whether to remove this check completely or to make it an option.- -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"- getList (fromIntegral dNameLen) getDName- where- getDName = do- dName <- getOpaque16- when (B.length dName == 0) $ fail "certrequest: invalid DN length"- dn <-- either fail return $ decodeASN1Object "cert request DistinguishedName" dName- return (2 + B.length dName, dn)--decodeCertVerify :: CurrentParams -> Get Handshake-decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)+---- -decodeClientKeyXchg :: CurrentParams -> Get Handshake-decodeClientKeyXchg cp =- -- case ClientKeyXchg <$> (remaining >>= getBytes)+decodeServerKeyXchg :: CurrentParams -> Get Handshake+decodeServerKeyXchg cp = case cParamsKeyXchgType cp of- Nothing -> error "no client key exchange type"- Just cke -> ClientKeyXchg <$> parseCKE cke- where- parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes)- parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic- parseCKE CipherKeyExchange_DHE_DSA = parseClientDHPublic- parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic- parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic- parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic- parseCKE _ = error "unsupported client key exchange type"- parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16- parseClientECDHPublic = CKX_ECDH <$> getOpaque8--decodeServerKeyXchg_DH :: Get ServerDHParams-decodeServerKeyXchg_DH = getServerDHParams---- We don't support ECDH_Anon at this moment--- decodeServerKeyXchg_ECDH :: Get ServerECDHParams--decodeServerKeyXchg_RSA :: Get ServerRSAParams-decodeServerKeyXchg_RSA =- ServerRSAParams- <$> getInteger16 -- modulus- <*> getInteger16 -- exponent+ Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke+ Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) decodeServerKeyXchgAlgorithmData :: Version@@ -296,12 +314,71 @@ bs <- remaining >>= getBytes return $ SKX_Unknown bs -decodeServerKeyXchg :: CurrentParams -> Get Handshake-decodeServerKeyXchg cp =+decodeServerKeyXchg_DH :: Get ServerDHParams+decodeServerKeyXchg_DH = getServerDHParams++-- We don't support ECDH_Anon at this moment+-- decodeServerKeyXchg_ECDH :: Get ServerECDHParams++decodeServerKeyXchg_RSA :: Get ServerRSAParams+decodeServerKeyXchg_RSA =+ ServerRSAParams+ <$> getInteger16 -- modulus+ <*> getInteger16 -- exponent++----++decodeCertRequest :: CurrentParams -> Get Handshake+decodeCertRequest _cp = do+ certTypes <- map CertificateType <$> getWords8+ sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms+ CertRequest certTypes sigHashAlgs <$> getDNames+ where+ getSignatureHashAlgorithms len =+ getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++----++decodeServerHelloDone :: Get Handshake+decodeServerHelloDone = return ServerHelloDone++decodeCertVerify :: CurrentParams -> Get Handshake+decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)++decodeClientKeyXchg :: CurrentParams -> Get Handshake+decodeClientKeyXchg cp =+ -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of- Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke- Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes)+ Nothing -> fail "no client key exchange type"+ Just cke -> ClientKeyXchg <$> parseCKE cke+ where+ parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes)+ parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic+ parseCKE CipherKeyExchange_DHE_DSA = parseClientDHPublic+ parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic+ parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic+ parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic+ parseCKE _ = fail "unsupported client key exchange type"+ -- 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)++----------------------------------------------------------------+-- encode HANDSHAKE+ encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = encodeHandshake' o@@ -313,28 +390,25 @@ encodeHandshakeHeader ty len = putWord8 (fromHandshakeType ty) >> putWord24 len encodeHandshake' :: Handshake -> ByteString-encodeHandshake' (ClientHello version random compressionIDs CH{..}) = runPut $ do- putBinaryVersion version- putClientRandom32 random+encodeHandshake' HelloRequest = ""+encodeHandshake' (ClientHello CH{..}) = runPut $ do+ putBinaryVersion chVersion+ putClientRandom32 chRandom putSession chSession- putWords16 chCiphers- putWords8 compressionIDs+ putWords16 $ map fromCipherId chCiphers+ putWords8 chComps putExtensions chExtensions- return ()-encodeHandshake' (ServerHello version random session cipherid compressionID exts) = runPut $ do- putBinaryVersion version- putServerRandom32 random- putSession session- putWord16 cipherid- putWord8 compressionID- putExtensions exts- return ()-encodeHandshake' (Certificate cc) = encodeCertificate cc-encodeHandshake' (ClientKeyXchg ckx) = runPut $ do- case ckx of- CKX_RSA encryptedPreMain -> putBytes encryptedPreMain- CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic- CKX_ECDH bytes -> putOpaque8 bytes+encodeHandshake' (ServerHello SH{..}) = runPut $ do+ putBinaryVersion shVersion+ putServerRandom32 shRandom+ putSession shSession+ putWord16 $ fromCipherId shCipher+ putWord8 shComp+ putExtensions shExtensions+encodeHandshake' (NewSessionTicket life ticket) = runPut $ do+ putWord32 life+ putOpaque16 ticket+encodeHandshake' (Certificate (CertificateChain_ cc)) = encodeCertificate cc encodeHandshake' (ServerKeyXchg skg) = runPut $ case skg of SKX_RSA _ -> error "encodeHandshake' SKX_RSA not implemented"@@ -344,10 +418,7 @@ SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_Unparsed bytes -> putBytes bytes- _ ->- error ("encodeHandshake': cannot handle: " ++ show skg)-encodeHandshake' HelloRequest = ""-encodeHandshake' ServerHelloDone = ""+ _ -> error ("encodeHandshake': cannot handle: " ++ show skg) encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do putWords8 (map fromCertificateType certTypes) putWords16 $@@ -356,14 +427,33 @@ ) sigAlgs putDNames certAuthorities+encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned-encodeHandshake' (Finished opaque) = runPut $ putBytes opaque-encodeHandshake' (NewSessionTicket life ticket) = runPut $ do- putWord32 life- putOpaque16 ticket+encodeHandshake' (ClientKeyXchg ckx) = runPut $ do+ case ckx of+ CKX_RSA encryptedPreMain -> putBytes encryptedPreMain+ CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic+ CKX_ECDH bytes -> putOpaque8 bytes+encodeHandshake' (Finished (VerifyData opaque)) = runPut $ putBytes opaque ------------------------------------------------------------+-- CA distinguished names +-- | Decode a list CA distinguished names+getDNames :: Get [DistinguishedName]+getDNames = do+ dNameLen <- getWord16+ -- FIXME: Decide whether to remove this check completely or to make it an option.+ -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"+ getList (fromIntegral dNameLen) getDName+ where+ getDName = do+ dName <- getOpaque16+ when (B.length dName == 0) $ fail "certrequest: invalid DN length"+ dn <-+ either fail return $ decodeASN1Object "cert request DistinguishedName" dName+ return (2 + B.length dName, dn)+ -- | Encode a list of distinguished names. putDNames :: [DistinguishedName] -> Put putDNames dnames = do@@ -375,6 +465,8 @@ -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1Object dn +------------------------------------------------------------+ {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString getRandom32 = getBytes 32@@ -394,17 +486,23 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r +------------------------------------------------------------+ getSession :: Get Session getSession = do len8 <- getWord8 case fromIntegral len8 of 0 -> return $ Session Nothing- len -> Session . Just <$> getBytes len+ len+ | len > 32 -> fail "the length of session id must be <= 32"+ | otherwise -> Session . Just <$> getBytes len putSession :: Session -> Put putSession (Session Nothing) = putWord8 0 putSession (Session (Just s)) = putOpaque8 s +------------------------------------------------------------+ getExtensions :: Int -> Get [ExtensionRaw] getExtensions 0 = return [] getExtensions len = do@@ -421,6 +519,8 @@ putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) +------------------------------------------------------------+ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- HashAlgorithm <$> getWord8@@ -431,12 +531,16 @@ putSignatureHashAlgorithm (HashAlgorithm h, SignatureAlgorithm s) = putWord8 h >> putWord8 s +------------------------------------------------------------+ getServerDHParams :: Get ServerDHParams getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum16 putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p, g, y] +------------------------------------------------------------+ -- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do@@ -446,19 +550,20 @@ -- ECParameters ECCurveType: curve name type grp <- Group <$> getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint- case decodeGroupPublic grp mxy of- Left e -> error $ "getServerECDHParams: " ++ show e+ case groupDecodePublicA grp mxy of+ Left e -> fail $ "getServerECDHParams: " ++ show e Right grppub -> return $ ServerECDHParams grp grppub- _ ->- error "getServerECDHParams: unknown type for ECDH Params"+ _ -> fail "getServerECDHParams: unknown type for ECDH Params" -- RFC 4492 Section 5.4 Server Key Exchange putServerECDHParams :: ServerECDHParams -> Put putServerECDHParams (ServerECDHParams (Group grp) grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 grp -- ECParameters NamedCurve- putOpaque8 $ encodeGroupPublic grppub -- ECPoint+ putOpaque8 $ groupEncodePublicA grppub -- ECPoint +------------------------------------------------------------+ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver = DigitallySigned@@ -469,17 +574,7 @@ putDigitallySigned (DigitallySigned h sig) = putSignatureHashAlgorithm h >> putOpaque16 sig -{-- - decode and encode ALERT- -}--decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec = runGetErr "changecipherspec" $ do- x <- getWord8- when (x /= 1) (fail "unknown change cipher spec content")--encodeChangeCipherSpec :: ByteString-encodeChangeCipherSpec = runPut (putWord8 1)+------------------------------------------------------------ -- RSA pre-main secret decodePreMainSecret :: ByteString -> Either TLSError (Version, ByteString)@@ -490,24 +585,8 @@ encodePreMainSecret :: Version -> ByteString -> ByteString encodePreMainSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) --- | in certain cases, we haven't manage to decode ServerKeyExchange properly,--- because the decoding was too eager and the cipher wasn't been set yet.--- we keep the Server Key Exchange in it unparsed format, and this function is--- able to really decode the server key xchange if it's unparsed.-decodeReallyServerKeyXchgAlgorithmData- :: Version- -> CipherKeyExchangeType- -> ByteString- -> Either TLSError ServerKeyXchgAlgorithmData-decodeReallyServerKeyXchgAlgorithmData ver cke =- runGetErr- "server-key-xchg-algorithm-data"- (decodeServerKeyXchgAlgorithmData ver cke)--{-- - generate things for packet content- -}-type PRF = ByteString -> ByteString -> Int -> ByteString+------------------------------------------------------------+-- generate things for packet content -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256.@@ -518,25 +597,23 @@ | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMainSecret_TLS- :: ByteArrayAccess preMain- => PRF- -> preMain+ :: PRF+ -> Secret -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) =- prf (B.convert preMainSecret) seed 48+ prf preMainSecret seed 48 where seed = B.concat ["master secret", c, s] generateMainSecret- :: ByteArrayAccess preMain- => Version+ :: Version -> Cipher- -> preMain+ -> Secret -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret generateMainSecret v c = generateMainSecret_TLS $ getPRF v c generateExtendedMainSecret@@ -545,14 +622,14 @@ -> Cipher -> preMain -> ByteString- -> ByteString+ -> Secret generateExtendedMainSecret v c preMainSecret sessionHash =- getPRF v c (B.convert preMainSecret) seed 48+ getPRF v c (convert preMainSecret) seed 48 where seed = B.append "extended master secret" sessionHash generateKeyBlock_TLS- :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString+ :: PRF -> ClientRandom -> ServerRandom -> Secret -> Int -> Secret generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize = prf mainSecret seed kbsize where@@ -563,33 +640,12 @@ -> Cipher -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret -> Int- -> ByteString+ -> Secret generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c -generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString-generateFinished_TLS prf label mainSecret hashctx = prf mainSecret seed 12- where- seed = B.concat [label, hashFinal hashctx]--generateClientFinished- :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateClientFinished ver ciph =- generateFinished_TLS (getPRF ver ciph) "client finished"--generateServerFinished- :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateServerFinished ver ciph =- generateFinished_TLS (getPRF ver ciph) "server finished"+------------------------------------------------------------ encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString@@ -610,3 +666,19 @@ encodeCertificate cc = runPut $ putOpaque24 (runPut $ mapM_ putOpaque24 certs) where (CertificateChainRaw certs) = encodeCertificateChain cc++------------------------------------------------------------++-- | in certain cases, we haven't manage to decode ServerKeyExchange properly,+-- because the decoding was too eager and the cipher wasn't been set yet.+-- we keep the Server Key Exchange in it unparsed format, and this function is+-- able to really decode the server key xchange if it's unparsed.+decodeReallyServerKeyXchgAlgorithmData+ :: Version+ -> CipherKeyExchangeType+ -> ByteString+ -> Either TLSError ServerKeyXchgAlgorithmData+decodeReallyServerKeyXchgAlgorithmData ver cke =+ runGetErr+ "server-key-xchg-algorithm-data"+ (decodeServerKeyXchgAlgorithmData ver cke)
Network/TLS/Packet13.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Packet13 ( encodeHandshake13,@@ -9,13 +10,18 @@ encodeCertificate13, ) where +import Codec.Compression.Zlib+import qualified Control.Exception as E import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.X509 ( CertificateChain, CertificateChainRaw (..), decodeCertificateChain, encodeCertificateChain, )+import System.IO.Unsafe+ import Network.TLS.ErrT import Network.TLS.Imports import Network.TLS.Packet@@ -24,6 +30,8 @@ import Network.TLS.Types import Network.TLS.Wire +----------------------------------------------------------------+ encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt where@@ -38,37 +46,62 @@ putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString-encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do- putBinaryVersion TLS12- putServerRandom32 random- putSession session- putWord16 cipherId- putWord8 0 -- compressionID nullCompression- putExtensions exts+encodeHandshake13' (ServerHello13 SH{..}) = runPut $ do+ putBinaryVersion shVersion+ putServerRandom32 shRandom+ putSession shSession+ putWord16 $ fromCipherId shCipher+ putWord8 shComp+ putExtensions shExtensions+encodeHandshake13'+ ( NewSessionTicket13+ life+ ageadd+ (TicketNonce nonce)+ (SessionIDorTicket_ label)+ exts+ ) = runPut $ do+ putWord32 life+ putWord32 ageadd+ putOpaque8 nonce+ putOpaque16 label+ putExtensions exts+encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts+encodeHandshake13' (Certificate13 reqctx (CertificateChain_ cc) ess) = encodeCertificate13 reqctx cc ess encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts-encodeHandshake13' (Certificate13 reqctx cc ess) = encodeCertificate13 reqctx cc ess-encodeHandshake13' (CertVerify13 hs signature) = runPut $ do+encodeHandshake13' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do putSignatureHashAlgorithm hs- putOpaque16 signature-encodeHandshake13' (Finished13 dat) = runPut $ putBytes dat-encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do- putWord32 life- putWord32 ageadd- putOpaque8 nonce- putOpaque16 label- putExtensions exts-encodeHandshake13' EndOfEarlyData13 = ""+ putOpaque16 sig+encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1+encodeHandshake13' (CompressedCertificate13 reqctx (CertificateChain_ cc) ess) = runPut $ do+ putWord16 1 -- zlib: fixme+ let bs = encodeCertificate13 reqctx cc ess+ putWord24 $ fromIntegral $ B.length bs+ putOpaque24 $ BL.toStrict $ compress $ BL.fromStrict bs encodeHandshakeHeader13 :: HandshakeType -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do putWord8 (fromHandshakeType ty) putWord24 len +encodeCertificate13+ :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString+encodeCertificate13 reqctx cc ess = runPut $ do+ putOpaque8 reqctx+ putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+ where+ CertificateChainRaw certs = encodeCertificateChain cc+ putCert (certRaw, exts) = do+ putOpaque24 certRaw+ putExtensions exts++----------------------------------------------------------------+ decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of GotError err -> throwError err@@ -83,35 +116,65 @@ 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 -} decodeHandshake13 :: HandshakeType -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of- HandshakeType_ServerHello -> decodeServerHello13- HandshakeType_Finished -> decodeFinished13- HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13- HandshakeType_CertRequest -> decodeCertRequest13- HandshakeType_Certificate -> decodeCertificate13- HandshakeType_CertVerify -> decodeCertVerify13- HandshakeType_NewSessionTicket -> decodeNewSessionTicket13- HandshakeType_EndOfEarlyData -> return EndOfEarlyData13- HandshakeType_KeyUpdate -> decodeKeyUpdate13+ HandshakeType_ServerHello -> decodeServerHello13+ HandshakeType_NewSessionTicket -> decodeNewSessionTicket13+ HandshakeType_EndOfEarlyData -> return EndOfEarlyData13+ HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13+ HandshakeType_Certificate -> decodeCertificate13+ HandshakeType_CertRequest -> decodeCertRequest13+ HandshakeType_CertVerify -> decodeCertVerify13+ HandshakeType_Finished -> decodeFinished13+ HandshakeType_KeyUpdate -> decodeKeyUpdate13+ HandshakeType_CompressedCertificate -> decodeCompressedCertificate13 (HandshakeType x) -> fail $ "Unsupported HandshakeType " ++ show x+{- FOURMOLU_ENABLE -} decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do- _ver <- getBinaryVersion+ ver <- getBinaryVersion random <- getServerRandom32 session <- getSession- cipherid <- getWord16- _comp <- getWord8- exts <- fromIntegral <$> getWord16 >>= getExtensions- return $ ServerHello13 random session cipherid exts+ cipherid <- CipherId <$> getWord16+ comp <- getWord8+ exts <- getWord16 >>= getExtensions . fromIntegral+ return $+ ServerHello13 $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = comp+ , shExtensions = exts+ } -decodeFinished13 :: Get Handshake13-decodeFinished13 = Finished13 <$> (remaining >>= getBytes)+decodeNewSessionTicket13 :: Get Handshake13+decodeNewSessionTicket13 = do+ life <- getWord32+ ageadd <- getWord32+ nonce <- TicketNonce <$> getOpaque8+ label <- SessionIDorTicket_ <$> getOpaque16+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ NewSessionTicket13 life ageadd nonce label exts decodeEncryptedExtensions13 :: Get Handshake13 decodeEncryptedExtensions13 =@@ -119,13 +182,6 @@ len <- fromIntegral <$> getWord16 getExtensions len -decodeCertRequest13 :: Get Handshake13-decodeCertRequest13 = do- reqctx <- getOpaque8- len <- fromIntegral <$> getWord16- exts <- getExtensions len- return $ CertRequest13 reqctx exts- decodeCertificate13 :: Get Handshake13 decodeCertificate13 = do reqctx <- getOpaque8@@ -133,7 +189,7 @@ (certRaws, ess) <- unzip <$> getList len getCert case decodeCertificateChain $ CertificateChainRaw certRaws of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s)- Right cc -> return $ Certificate13 reqctx cc ess+ Right cc -> return $ Certificate13 reqctx (CertificateChain_ cc) ess where getCert = do l <- fromIntegral <$> getWord24@@ -142,19 +198,20 @@ exts <- getExtensions len return (3 + l + 2 + len, (cert, exts)) -decodeCertVerify13 :: Get Handshake13-decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16--decodeNewSessionTicket13 :: Get Handshake13-decodeNewSessionTicket13 = do- life <- getWord32- ageadd <- getWord32- nonce <- getOpaque8- label <- getOpaque16+decodeCertRequest13 :: Get Handshake13+decodeCertRequest13 = do+ reqctx <- getOpaque8 len <- fromIntegral <$> getWord16 exts <- getExtensions len- return $ NewSessionTicket13 life ageadd nonce label exts+ return $ CertRequest13 reqctx exts +decodeCertVerify13 :: Get Handshake13+decodeCertVerify13 =+ CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16)++decodeFinished13 :: Get Handshake13+decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes)+ decodeKeyUpdate13 :: Get Handshake13 decodeKeyUpdate13 = do ru <- getWord8@@ -163,13 +220,39 @@ 1 -> return $ KeyUpdate13 UpdateRequested x -> fail $ "Unknown request_update: " ++ show x -encodeCertificate13- :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString-encodeCertificate13 reqctx cc ess = runPut $ do- putOpaque8 reqctx- putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+-- 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 "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 len bs of+ Left e -> fail $ "certificate cannot be decompressed: " ++ show e+ Right bs' -> do+ 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 :: 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- CertificateChainRaw certs = encodeCertificateChain cc- putCert (certRaw, exts) = do- putOpaque24 certRaw- putExtensions exts+ handler :: DecompressError -> IO (Either DecompressError ByteString)+ handler e = return $ Left e
Network/TLS/Parameters.hs view
@@ -1,17 +1,26 @@+{-# LANGUAGE Strict #-}+ module Network.TLS.Parameters ( ClientParams (..),+ defaultParamsClient, ServerParams (..),+ defaultParamsServer, CommonParams, DebugParams (..),+ defaultDebugParams,+ defaultKeyLogger, ClientHooks (..),+ defaultClientHooks, OnCertificateRequest, OnServerCertificate, ServerHooks (..),+ defaultServerHooks, Supported (..),+ defaultSupported, Shared (..),-- -- * special default- defaultParamsClient,+ defaultShared,+ Limit (..),+ defaultLimit, -- * Parameters MaxFragmentEnum (..),@@ -19,16 +28,23 @@ GroupUsage (..), CertificateUsage (..), CertificateRejectReason (..),+ Information (..), ) where -import qualified Data.ByteString as B-import Data.Default.Class+import Control.Concurrent (MVar, newMVar, withMVar)+import Crypto.HPKE+import Data.Default (Default (def))+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto+import Network.TLS.ECH.Config import Network.TLS.Extension import Network.TLS.Extra.Cipher+import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.RNG (Seed)@@ -49,7 +65,7 @@ -- -- Default: 'Nothing' , debugPrintSeed :: Seed -> IO ()- -- ^ Add a way to print the seed that was randomly generated. re-using the same seed+ -- ^ Add a way to print the seed that was randomly generated. reusing the same seed -- will reproduce the same randomness with 'debugSeed' -- -- Default: no printing@@ -61,15 +77,34 @@ -- ^ Printing main keys. -- -- Default: no printing+ , debugError :: String -> IO ()+ , debugTraceKey :: String -> IO () } +{-# NOINLINE keyLogLock #-}+keyLogLock :: MVar ()+keyLogLock = unsafePerformIO $ newMVar ()++{-# NOINLINE keyLogFile #-}+keyLogFile :: Maybe FilePath+keyLogFile = unsafePerformIO $ lookupEnv "SSLKEYLOGFILE"++-- | Key logger with the SSLKEYLOGFILE environment variable.+defaultKeyLogger :: String -> IO ()+defaultKeyLogger ~msg = case keyLogFile of+ Nothing -> return ()+ Just file -> withMVar keyLogLock $ \_ -> appendFile file (msg ++ "\n")++-- | Default value for 'DebugParams' defaultDebugParams :: DebugParams defaultDebugParams = DebugParams { debugSeed = Nothing , debugPrintSeed = const (return ()) , debugVersionForced = Nothing- , debugKeyLogger = \_ -> return ()+ , debugKeyLogger = defaultKeyLogger+ , debugError = \ ~_ -> return ()+ , debugTraceKey = \ ~_ -> return () } instance Show DebugParams where@@ -77,53 +112,88 @@ instance Default DebugParams where def = defaultDebugParams +{-# DEPRECATED clientUseMaxFragmentLength "UseMaxFragmentLength is deprecated" #-}+ data ClientParams = ClientParams { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum -- ^ -- -- Default: 'Nothing' , clientServerIdentification :: (HostName, ByteString)- -- ^ Define the name of the server, along with an extra service identification blob.- -- this is important that the hostname part is properly filled for security reason,- -- as it allow to properly associate the remote side with the given certificate- -- during a handshake.+ -- ^ Define the name of the server, along with an extra service+ -- identification blob. this is important that the hostname part+ -- is properly filled for security reason, as it allow to properly+ -- associate the remote side with the given certificate during a+ -- handshake. --- -- The extra blob is useful to differentiate services running on the same host, but that- -- might have different certificates given. It's only used as part of the X509 validation+ -- The extra blob is useful to differentiate services running on+ -- the same host, but that might have different certificates+ -- given. It's only used as part of the X509 validation -- infrastructure. -- -- This value is typically set by 'defaultParamsClient'. , clientUseServerNameIndication :: Bool- -- ^ Allow the use of the Server Name Indication TLS extension during handshake, which allow- -- the client to specify which host name, it's trying to access. This is useful to distinguish+ -- ^ Allow the use of the Server Name Indication TLS extension+ -- during handshake, which allow the client to specify which host+ -- name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). -- -- Default: 'True' , clientWantSessionResume :: Maybe (SessionID, SessionData)- -- ^ try to establish a connection using this session.+ -- ^ try to establish a connection using this session for TLS+ -- 1.2/TLS 1.3. This can be used for TLS 1.3 but for backward+ -- compatibility purpose only. Use 'clientWantSessionResume13'+ -- instead for TLS 1.3. -- -- Default: 'Nothing'+ , clientWantSessionResumeList :: [(SessionID, SessionData)]+ -- ^ try to establish a connection using one of this sessions+ -- especially for TLS 1.3. This take precedence over+ -- 'clientWantSessionResume'. For convenience, this can be+ -- 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 -- ^ See the default value of 'ClientHooks'. , clientSupported :: Supported- -- ^ In this element, you'll need to override the default empty value of- -- of 'supportedCiphers' with a suitable cipherlist.+ -- ^ In this element, you'll need to override the default empty+ -- value of of 'supportedCiphers' with a suitable cipherlist. -- -- See the default value of 'Supported'. , clientDebug :: DebugParams -- ^ See the default value of 'DebugParams'. , clientUseEarlyData :: Bool- -- ^ Client tries to send early data in TLS 1.3- -- via 'sendData' if possible.- -- If not accepted by the server, the early data- -- is automatically re-sent.+ -- ^ Client tries to send early data in TLS 1.3 via 'sendData' if+ -- possible. If not accepted by the server, the early data is+ -- automatically re-sent. -- -- Default: 'False'+ , clientUseECH :: Bool+ -- ^ Enabling Encrypted Client Hello.+ -- If 'sharedECHConfigList' is null, a greasing ECH extension is sent.+ -- Otherwise, a valid ECH is sent.+ -- If the server rejects ECH in Server Hello,+ -- the client sends an alert after negotiation.+ --+ -- Default: 'False'+ --+ -- @since 2.1.9 } deriving (Show) +-- | Default value for 'ClientParams' defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams@@ -131,11 +201,14 @@ , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientWantSessionResume = Nothing+ , clientWantSessionResumeList = []+ , clientWantTicket = True , clientShared = def , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams , clientUseEarlyData = False+ , clientUseECH = False } data ServerParams = ServerParams@@ -144,15 +217,15 @@ -- -- Default: 'False' , serverCACertificates :: [SignedCertificate]- -- ^ This is a list of certificates from which the- -- disinguished names are sent in certificate request- -- messages. For TLS1.0, it should not be empty.+ -- ^ This is a list of certificates from which the disinguished+ -- names are sent in certificate request messages. For TLS1.0, it+ -- should not be empty. -- -- Default: '[]' , serverDHEParams :: Maybe DHParams- -- ^ Server Optional Diffie Hellman parameters. Setting parameters is- -- necessary for FFDHE key exchange when clients are not compatible- -- with RFC 7919.+ -- ^ Server Optional Diffie Hellman parameters. Setting+ -- parameters is necessary for FFDHE key exchange when clients are+ -- not compatible with RFC 7919. -- -- Value can be one of the standardized groups from module -- "Network.TLS.Extra.FFDHE" or custom parameters generated with@@ -168,15 +241,21 @@ , serverDebug :: DebugParams -- ^ See the default value of 'DebugParams'. , serverEarlyDataSize :: Int- -- ^ Server accepts this size of early data in TLS 1.3.- -- 0 (or lower) means that the server does not accept early data.+ -- ^ Server accepts this size of early data in TLS 1.3. 0 (or+ -- lower) means that the server does not accept early data. -- -- Default: 0 , serverTicketLifetime :: Int- -- ^ Lifetime in seconds for session tickets generated by the server.- -- Acceptable value range is 0 to 604800 (7 days).+ -- ^ Lifetime in seconds for session tickets generated by the+ -- server. Acceptable value range is 0 to 604800 (7 days). -- -- Default: 7200 (2 hours)+ , serverECHKey :: [(ConfigId, ByteString)]+ -- ^ ECH secret keys.+ --+ -- Default: '[]'+ --+ -- @since 2.1.9 } deriving (Show) @@ -192,6 +271,7 @@ , serverDebug = defaultDebugParams , serverEarlyDataSize = 0 , serverTicketLifetime = 7200+ , serverECHKey = [] } instance Default ServerParams where@@ -200,26 +280,27 @@ -- | List all the supported algorithms, versions, ciphers, etc supported. data Supported = Supported { supportedVersions :: [Version]- -- ^ Supported versions by this context. On the client side, the highest- -- version will be used to establish the connection. On the server side,- -- the highest version that is less or equal than the client version will- -- be chosen.+ -- ^ Supported versions by this context. On the client side, the+ -- highest version will be used to establish the connection. On+ -- the server side, the highest version that is less or equal than+ -- the client version will be chosen. --- -- Versions should be listed in preference order, i.e. higher versions- -- first.+ -- Versions should be listed in preferred order, i.e. higher+ -- versions first. -- -- Default: @[TLS13,TLS12]@ , supportedCiphers :: [Cipher]- -- ^ Supported cipher methods. The default is empty, specify a suitable- -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often- -- a good choice.+ -- ^ Supported cipher methods. The default is empty, specify a+ -- suitable cipher list.+ -- 'Network.TLS.Extra.Cipher.ciphersuite_default' is often a good+ -- choice. -- -- Default: @[]@ , supportedCompressions :: [Compression] -- ^ Supported compressions methods. By default only the "null"- -- compression is supported, which means no compression will be performed.- -- Allowing other compression method is not advised as it causes a- -- connection failure when TLS 1.3 is negotiated.+ -- compression is supported, which means no compression will be+ -- performed. Allowing other compression method is not advised as+ -- it causes a connection failure when TLS 1.3 is negotiated. -- -- Default: @[nullCompression]@ , supportedHashSignatures :: [HashAndSignatureAlgorithm]@@ -227,18 +308,19 @@ -- certificate verification and server signature in (EC)DHE, -- ordered by decreasing priority. --- -- This list is sent to the peer as part of the "signature_algorithms"- -- extension. It is used to restrict accepted signatures received from- -- the peer at TLS level (not in X.509 certificates), but only when the- -- TLS version is 1.2 or above. In order to disable SHA-1 one must then- -- also disable earlier protocol versions in 'supportedVersions'.+ -- This list is sent to the peer as part of the+ -- "signature_algorithms" extension. It is used to restrict+ -- accepted signatures received from the peer at TLS level (not in+ -- X.509 certificates), but only when the TLS version is 1.2 or+ -- above. In order to disable SHA-1 one must then also disable+ -- earlier protocol versions in 'supportedVersions'. -- -- The list also impacts the selection of possible algorithms when -- generating signatures. --- -- Note: with TLS 1.3 some algorithms have been deprecated and will not be- -- used even when listed in the parameter: MD5, SHA-1, SHA-224, RSA- -- PKCS#1, DSA.+ -- Note: with TLS 1.3 some algorithms have been deprecated and+ -- will not be used even when listed in the parameter: MD5, SHA-1,+ -- SHA-224, RSA PKCS#1, DSA. -- -- Default: --@@ -259,62 +341,87 @@ -- ] -- @ , supportedSecureRenegotiation :: Bool- -- ^ Secure renegotiation defined in RFC5746.- -- If 'True', clients send the renegotiation_info extension.- -- If 'True', servers handle the extension or the renegotiation SCSV- -- then send the renegotiation_info extension.+ -- ^ Secure renegotiation defined in RFC5746. If 'True', clients+ -- send the renegotiation_info extension. If 'True', servers+ -- handle the extension or the renegotiation SCSV then send the+ -- renegotiation_info extension. -- -- Default: 'True' , supportedClientInitiatedRenegotiation :: Bool -- ^ If 'True', renegotiation is allowed from the client side.- -- This is vulnerable to DOS attacks.- -- If 'False', renegotiation is allowed only from the server side- -- via HelloRequest.+ -- This is vulnerable to DOS attacks. If 'False', renegotiation+ -- is allowed only from the server side via HelloRequest. -- -- Default: 'False' , supportedExtendedMainSecret :: EMSMode- -- ^ The mode regarding extended main secret. Enabling this extension- -- provides better security for TLS versions 1.2. TLS 1.3 provides- -- the security properties natively and does not need the extension.- --- -- By default the extension is 'RequireEMS'.- -- So, the handshake will fail when the peer does not support+ -- ^ The mode regarding extended main secret. Enabling this+ -- extension provides better security for TLS versions 1.2. TLS+ -- 1.3 provides the security properties natively and does not need -- the extension. --+ -- By default the extension is 'RequireEMS'. So, the handshake+ -- will fail when the peer does not support the extension.+ -- -- Default: 'RequireEMS' , supportedSession :: Bool -- ^ Set if we support session. -- -- Default: 'True' , supportedFallbackScsv :: Bool- -- ^ Support for fallback SCSV defined in RFC7507.- -- If 'True', servers reject handshakes which suggest- -- a lower protocol than the highest protocol supported.+ -- ^ Support for fallback SCSV defined in RFC7507. If 'True',+ -- servers reject handshakes which suggest a lower protocol than+ -- the highest protocol supported. -- -- Default: 'True' , supportedEmptyPacket :: Bool- -- ^ In ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed- -- by an attacker. Hence, an empty packet is normally sent before a normal data packet, to- -- prevent guessability. Some Microsoft TLS-based protocol implementations, however,- -- consider these empty packets as a protocol violation and disconnect. If this parameter is- -- 'False', empty packets will never be added, which is less secure, but might help in rare- -- cases.+ -- ^ In ver <= TLS1.0, block ciphers using CBC are using CBC+ -- residue as IV, which can be guessed by an attacker. Hence, an+ -- empty packet is normally sent before a normal data packet, to+ -- prevent guessability. Some Microsoft TLS-based protocol+ -- implementations, however, consider these empty packets as a+ -- protocol violation and disconnect. If this parameter is+ -- 'False', empty packets will never be added, which is less+ -- secure, but might help in rare cases. -- -- Default: 'True'+ , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -- ^ Client only.+ --+ -- @since 2.1.9 , supportedGroups :: [Group]- -- ^ A list of supported elliptic curves and finite-field groups in the- -- preferred order.+ -- ^ A list of supported elliptic curves and finite-field groups+ -- in preferred order. --- -- The list is sent to the server as part of the "supported_groups"- -- extension. It is used in both clients and servers to restrict- -- accepted groups in DH key exchange. Up until TLS v1.2, it is also- -- used by a client to restrict accepted elliptic curves in ECDSA- -- signatures.+ -- * TLS 1.3 client: this list is used as the 1st argument to+ -- 'onSelectKeyShareGroups' to select groups in "key_share".+ -- This list is also used as values of "supported_groups".+ -- * TLS 1.3 server: this list is not used.+ -- * TLS 1.2 client: this list is also used as values of+ -- "supported_groups".+ -- * TLS 1.2 server: this list is used to select a key exchange+ -- mechanism. --- -- The default value includes all groups with security strength of 128- -- bits or more.+ -- The list is sent to the server as part of the+ -- "supported_groups" extension. It is used in both clients and+ -- servers to restrict accepted groups in DH key exchange. Up+ -- until TLS v1.2, it is also used by a client to restrict+ -- accepted elliptic curves in ECDSA signatures. --- -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@+ -- The default value includes all groups with security strength+ -- of 128 bits or more.+ --+ -- Default: @[X25519,P256,P384,X448,P521,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192,X25519MLKEM768,P256MLKEM768,P384MLKEM1024,MLKEM768,MLKEM1024]@+ , supportedGroupsTLS13 :: [[Group]]+ -- ^ The inside @[Group]@ is the list of @Group@ at the same level+ -- in preferred order. The inside @[Group]@s are also listed in+ -- preferred order.+ --+ -- TLS 1.3 server: this is used as the 1st argument to+ -- 'onSelectKeyShare'.+ --+ -- Default: @[[X25519MLKEM768,P256MLKEM768,P384MLKEM1024],[X25519,P256],[P384,X448,P521],[FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192],[MLKEM768,MLKEM1024]]@+ --+ -- @since 2.2.3 } deriving (Show, Eq) @@ -328,6 +435,16 @@ RequireEMS deriving (Show, Eq) +defaultHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+defaultHPKE =+ [ (DHKEM_X25519_HKDF_SHA256, HKDF_SHA256, AES_128_GCM)+ , (DHKEM_X25519_HKDF_SHA256, HKDF_SHA256, ChaCha20Poly1305)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA256, AES_128_GCM)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA512, AES_128_GCM)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA256, ChaCha20Poly1305)+ , (DHKEM_P521_HKDF_SHA512, HKDF_SHA512, AES_256_GCM)+ ]+ defaultSupported :: Supported defaultSupported = Supported@@ -341,7 +458,9 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True+ , supportedHPKE = defaultHPKE , supportedGroups = supportedNamedGroups+ , supportedGroupsTLS13 = supportedNamedGroupsTLS13 } instance Default Supported where@@ -350,11 +469,11 @@ -- | Parameters that are common to clients and servers. data Shared = Shared { sharedCredentials :: Credentials- -- ^ The list of certificates and private keys that a server will use as- -- part of authentication to clients. Actual credentials that are used- -- are selected dynamically from this list based on client capabilities.- -- Additional credentials returned by 'onServerNameIndication' are also- -- considered.+ -- ^ The list of certificates and private keys that a server will+ -- use as part of authentication to clients. Actual credentials+ -- that are used are selected dynamically from this list based on+ -- client capabilities. Additional credentials returned by+ -- 'onServerNameIndication' are also considered. -- -- When credential list is left empty (the default value), no key -- exchange can take place.@@ -362,49 +481,63 @@ -- Default: 'mempty' , sharedSessionManager :: SessionManager -- ^ Callbacks used by clients and servers in order to resume TLS- -- sessions. The default implementation never resumes sessions. Package- -- <https://hackage.haskell.org/package/tls-session-manager tls-session-manager>- -- provides an in-memory implementation.+ -- sessions. The default implementation never resumes sessions.+ -- Package+ -- <https://hackage.haskell.org/package/tls-session-manager+ -- tls-session-manager> provides an in-memory implementation. -- -- Default: 'noSessionManager' , sharedCAStore :: CertificateStore- -- ^ A collection of trust anchors to be used by a client as- -- part of validation of server certificates. This is set as- -- first argument to function 'onServerCertificate'. Package- -- <https://hackage.haskell.org/package/crypton-x509-system crypton-x509-system>- -- gives access to a default certificate store configured in the- -- system.+ -- ^ A collection of trust anchors to be used by a client as part+ -- of validation of server certificates. This is set as first+ -- argument to function 'onServerCertificate'. Package+ -- <https://hackage.haskell.org/package/crypton-x509-system+ -- crypton-x509-system> gives access to a default certificate+ -- store configured in the system. -- -- Default: 'mempty' , sharedValidationCache :: ValidationCache -- ^ Callbacks that may be used by a client to cache certificate -- validation results (positive or negative) and avoid expensive- -- signature check. The default implementation does not have- -- any caching.+ -- signature check. The default implementation does not have any+ -- caching. -- -- See the default value of 'ValidationCache'. , sharedHelloExtensions :: [ExtensionRaw] -- ^ Additional extensions to be sent during the Hello sequence. --- -- For a client this is always included in message ClientHello. For a- -- server, this is sent in messages ServerHello or EncryptedExtensions- -- based on the TLS version.+ -- For a client this is always included in message ClientHello.+ -- For a server, this is sent in messages ServerHello or+ -- EncryptedExtensions based on the TLS version. -- -- Default: @[]@+ , sharedECHConfigList :: ECHConfigList+ -- ^ ECH configuration.+ --+ -- @since 2.1.9+ , sharedLimit :: Limit+ -- ^ Limitation parameters.+ --+ -- @since 2.1.8 } instance Show Shared where show _ = "Shared" instance Default Shared where- def =- Shared- { sharedCredentials = mempty- , sharedSessionManager = noSessionManager- , sharedCAStore = mempty- , sharedValidationCache = def- , sharedHelloExtensions = []- }+ def = defaultShared +defaultShared :: Shared+defaultShared =+ Shared+ { sharedCredentials = mempty+ , sharedSessionManager = noSessionManager+ , sharedCAStore = mempty+ , sharedValidationCache = def+ , sharedHelloExtensions = []+ , sharedECHConfigList = []+ , sharedLimit = defaultLimit+ }+ -- | Group usage callback possible return values. data GroupUsage = -- | usage of group accepted@@ -452,91 +585,129 @@ { onCertificateRequest :: OnCertificateRequest -- ^ This action is called when the a certificate request is -- received from the server. The callback argument is the- -- information from the request. The server, at its- -- discretion, may be willing to continue the handshake- -- without a client certificate. Therefore, the callback is- -- free to return 'Nothing' to indicate that no client- -- certificate should be sent, despite the server's request.- -- In some cases it may be appropriate to get user consent- -- before sending the certificate; the content of the user's- -- certificate may be sensitive and intended only for- -- specific servers.+ -- information from the request. The server, at its discretion,+ -- may be willing to continue the handshake without a client+ -- certificate. Therefore, the callback is free to return+ -- 'Nothing' to indicate that no client certificate should be+ -- sent, despite the server's request. In some cases it may be+ -- appropriate to get user consent before sending the certificate;+ -- the content of the user's certificate may be sensitive and+ -- intended only for specific servers. --- -- The action should select a certificate chain of one of- -- the given certificate types and one of the certificates- -- in the chain should (if possible) be signed by one of the- -- given distinguished names. Some servers, that don't have- -- a narrow set of preferred issuer CAs, will send an empty- -- 'DistinguishedName' list, rather than send all the names- -- from their trusted CA bundle. If the client does not- -- have a certificate chaining to a matching CA, it may- -- choose a default certificate instead.+ -- The action should select a certificate chain of one of the+ -- given certificate types and one of the certificates in the+ -- chain should (if possible) be signed by one of the given+ -- distinguished names. Some servers, that don't have a narrow+ -- set of preferred issuer CAs, will send an empty+ -- 'DistinguishedName' list, rather than send all the names from+ -- their trusted CA bundle. If the client does not have a+ -- certificate chaining to a matching CA, it may choose a default+ -- certificate instead. -- -- Each certificate except the last should be signed by the- -- following one. The returned private key must be for the- -- first certificates in the chain. This key will be used- -- to signing the certificate verify message.+ -- following one. The returned private key must be for the first+ -- certificates in the chain. This key will be used to signing+ -- the certificate verify message. -- -- 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 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 hash and key. For details see+ -- returned private key must be compatible with one of the list of+ -- 'HashAndSignatureAlgorithm' 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+ -- hash and key. For details see -- <https://tools.ietf.org/html/rfc8446#section-4.2.3 RFC 8446> -- section 4.2.3. When no compatible certificate chain is- -- available, return 'Nothing' if it is OK to continue- -- without a client certificate. Returning a non-matching- -- certificate should result in a handshake failure.+ -- available, return 'Nothing' if it is OK to continue without a+ -- client certificate. Returning a non-matching certificate+ -- should result in a handshake failure. --- -- 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@).+ -- 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@). --- -- 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.+ -- 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. -- -- Default: returns 'Nothing' anyway. , onServerCertificate :: OnServerCertificate- -- ^ Used by the client to validate the server certificate. The default- -- implementation calls 'validateDefault' which validates according to the- -- default hooks and checks provided by "Data.X509.Validation". This can- -- be replaced with a custom validation function using different settings.+ -- ^ Used by the client to validate the server certificate. The+ -- default implementation calls 'validateDefault' which validates+ -- according to the default hooks and checks provided by+ -- "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 [B.ByteString])+ , onSuggestALPN :: IO (Maybe [ByteString]) -- ^ This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. -- -- Default: returns 'Nothing' , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage- -- ^ This action is called to validate DHE parameters when the server- -- selected a finite-field group not part of the "Supported Groups- -- Registry" or not part of 'supportedGroups' list.+ -- ^ This action is called to validate DHE parameters when the+ -- server selected a finite-field group not part of the+ -- "Supported Groups Registry" or not part of 'supportedGroups'+ -- list. --- -- With TLS 1.3 custom groups have been removed from the protocol, so- -- this callback is only used when the version negotiated is 1.2 or- -- below.+ -- With TLS 1.3 custom groups have been removed from the+ -- protocol, so this callback is only used when the version+ -- negotiated is 1.2 or below. --- -- The default behavior with (dh_p, dh_g, dh_size) and pub as follows:+ -- The default behavior with (dh_p, dh_g, dh_size) and pub as+ -- follows: -- -- (1) rejecting if dh_p is even -- (2) rejecting unless 1 < dh_g && dh_g < dh_p - 1 -- (3) rejecting unless 1 < dh_p && pub < dh_p - 1 -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack) --- -- See RFC 7919 section 3.1 for recommandations.+ -- See RFC 7919 section 3.1 for recommendations.+ , onServerFinished :: Information -> IO ()+ -- ^ When a handshake is done, this hook can check `Information`.+ , onSelectKeyShareGroups :: [Group] -> [Group]+ -- ^ A function to select groups in "key_share" by TLS 1.3 client.+ --+ -- Client's 'supportedGroups' is passed as the 1st argument.+ --+ -- The default function specifies a pair of hybrid (classical ++ -- post quantum) group and classical group to transit from+ -- classical key exchange to hybrid key exchange. With the+ -- default value of 'supportedGroups', X25519MLKEM and X25519+ -- are chosen.+ --+ -- Middleboxes may drop a ClientHello that contains large+ -- X2219MLKEM. In such environment, @take 1@, which selects+ -- X22519 only with the default value, is maybe a good+ -- candidate.+ --+ -- In the case where X22519 is only contained in "key_share", a+ -- wise-server without nasty middleboxes may ask the client to+ -- send X2219MLKEM via HelloRetryRequest as X2219MLKEM is+ -- specified in "supported_groups".+ --+ -- @since 2.2.3 } +defaultOnSelectKeyShareGroups :: [Group] -> [Group]+defaultOnSelectKeyShareGroups groups = take 1 hs ++ take 1 es+ where+ (hs, es) = partition isHybrid groups++isHybrid :: Group -> Bool+isHybrid X25519MLKEM768 = True+isHybrid P256MLKEM768 = True+isHybrid P384MLKEM1024 = True+isHybrid _ = False+ defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks@@ -544,6 +715,8 @@ , onServerCertificate = validateDefault , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024+ , onServerFinished = \_ -> return ()+ , onSelectKeyShareGroups = defaultOnSelectKeyShareGroups } instance Show ClientHooks where@@ -554,58 +727,58 @@ -- | A set of callbacks run by the server for various corners of the TLS establishment data ServerHooks = ServerHooks { onClientCertificate :: CertificateChain -> IO CertificateUsage- -- ^ This action is called when a client certificate chain- -- is received from the client. When it returns a+ -- ^ This action is called when a client certificate chain is+ -- received from the client. When it returns a -- CertificateUsageReject value, the handshake is aborted. --- -- The function is not expected to verify the key-usage- -- extension of the certificate. This verification is- -- performed by the library internally.+ -- The function is not expected to verify the key-usage extension+ -- 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") -- @ , onUnverifiedClientCert :: IO Bool- -- ^ This action is called when the client certificate- -- cannot be verified. Return 'True' to accept the certificate- -- anyway, or 'False' to fail verification.+ -- ^ This action is called when the client certificate cannot be+ -- verified. Return 'True' to accept the certificate anyway, or+ -- 'False' to fail verification. -- -- Default: returns 'False' , onCipherChoosing :: Version -> [Cipher] -> Cipher- -- ^ Allow the server to choose the cipher relative to the- -- the client version and the client list of ciphers.+ -- ^ Allow the server to choose the cipher relative to the the+ -- 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)+ -- This could be useful with old clients and as a workaround to+ -- the BEAST (where RC4 is sometimes preferred with TLS < 1.1) -- -- The client cipher list cannot be empty. -- -- Default: taking the head of ciphers. , onServerNameIndication :: Maybe HostName -> IO Credentials- -- ^ Allow the server to indicate additional credentials- -- to be used depending on the host name indicated by the- -- client.+ -- ^ Allow the server to indicate additional credentials to be+ -- used depending on the host name indicated by the client. --- -- This is most useful for transparent proxies where- -- credentials must be generated on the fly according to- -- the host the client is trying to connect to.+ -- This is most useful for transparent proxies where credentials+ -- must be generated on the fly according to the host the client+ -- is trying to connect to. --- -- Returned credentials may be ignored if a client does not support- -- the signature algorithms used in the certificate chain.+ -- Returned credentials may be ignored if a client does not+ -- support the signature algorithms used in the certificate chain. -- -- Default: returns 'mempty' , onNewHandshake :: Measurement -> IO Bool- -- ^ At each new handshake, we call this hook to see if we allow handshake to happens.+ -- ^ At each new handshake, we call this hook to see if we allow+ -- handshake to happens. -- -- Default: returns 'True'- , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)+ , onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString) -- ^ Allow the server to choose an application layer protocol- -- suggested from the client through the ALPN- -- (Application Layer Protocol Negotiation) extensions.- -- If the server supports no protocols that the client advertises- -- an empty 'ByteString' should be returned.+ -- suggested from the client through the ALPN (Application Layer+ -- Protocol Negotiation) extensions. If the server supports no+ -- protocols that the client advertises an empty 'ByteString'+ -- should be returned. -- -- Default: 'Nothing' , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]@@ -613,8 +786,32 @@ -- of TLS 1.3. -- -- Default: 'return'+ , onSelectKeyShare+ :: [[Group]]+ -> [Group]+ -> [Group]+ -> IO (Maybe Group, Bool)+ -- ^ A function to select one key share by TLS 1.3 server.+ --+ -- The 1st argument is server's 'supportedGroupsTLS13'.+ -- The 2nd arguments is client's groups in "supported_groups"+ -- The 3rd arguments is client's groups in "key_share".+ --+ -- 'True' in the result indicates sending a hello retry request+ -- with this group.+ --+ -- The default function targets @[Group]@ in the first argument in+ -- order. If there is a common group among the "key_share"+ -- groups, it will use that group for key exchange.+ -- Alternatively, if there is a common group among the+ -- "supported_groups" groups, it will instruct to send the+ -- HelloRetryRequest using that group. Otherwise, it will check+ -- the next @[Group]@.+ --+ -- @since 2.2.3 } +-- | Default value for 'ServerHooks' defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks@@ -623,14 +820,90 @@ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False- , onCipherChoosing = \_ -> head+ , onCipherChoosing = \_ ccs -> case ccs of+ [] -> error "onCipherChoosing"+ c : _ -> c , onServerNameIndication = \_ -> return mempty , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing , onEncryptedExtensionsCreating = return+ , onSelectKeyShare = defaultOnSelectKeyShare } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks++defaultOnSelectKeyShare+ :: [[Group]] -- Server groups+ -> [Group] -- Client's groups in "supported_groups"+ -> [Group] -- Client's groups in "key_share"+ -> IO (Maybe Group, Bool)+defaultOnSelectKeyShare serverSupportedLoL clientSupportedGroups clientKeyShareGroups = go serverSupportedLoL+ where+ go [] = return (Nothing, False)+ go (gs : gss) = case gs `intersect` clientKeyShareGroups of+ [] -> case gs `intersect` clientSupportedGroups of+ [] -> go gss+ h : _ -> return (Just h, True)+ g : _ -> return (Just g, False)++-- | Information related to a running context, e.g. current cipher+data Information = Information+ { infoVersion :: Version+ , infoCipher :: Cipher+ , infoCompression :: Compression+ , infoMainSecret :: Maybe ByteString+ , infoExtendedMainSecret :: Bool+ , infoClientRandom :: Maybe ClientRandom+ , infoServerRandom :: Maybe ServerRandom+ , infoSupportedGroup :: Maybe Group+ , infoTLS12Resumption :: Bool+ , infoTLS13HandshakeMode :: Maybe HandshakeMode13+ , infoIsEarlyDataAccepted :: Bool+ , infoIsECHAccepted :: Bool+ }+ deriving (Show, Eq)++-- | Limitations for security.+--+-- @since 2.1.7+data Limit = Limit+ { limitRecordSize :: Maybe Int+ -- ^ Record size limit defined in RFC 8449.+ --+ -- If 'Nothing', the "record_size_limit" extension is not used.+ --+ -- In the case of 'Just': A client sends the "record_size_limit"+ -- extension with this value to the server. A server sends back+ -- this extension with its own value if a client sends the+ -- extension. When negotiated, both my limit and peer's limit are+ -- enabled for protected communication.+ --+ -- 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.+ --+ -- Default: 32+ , 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@+ }+ deriving (Eq, Show)++-- | Default value for 'Limit'.+defaultLimit :: Limit+defaultLimit =+ Limit+ { limitRecordSize = Nothing+ , limitHandshakeFragment = 32+ , limitKeyUpdate = Just 32+ }
Network/TLS/PostHandshake.hs view
@@ -3,30 +3,31 @@ requestCertificateServer, postHandshakeAuthWith, postHandshakeAuthClientWith,- postHandshakeAuthServerWith, ) where import Network.TLS.Context.Internal-import Network.TLS.IO-import Network.TLS.Struct13- import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.IO+import Network.TLS.Struct13 --- | Post-handshake certificate request with TLS 1.3. Returns 'True' if the--- request was possible, i.e. if TLS 1.3 is used and the remote client supports--- post-handshake authentication.+----------------------------------------------------------------++-- | Post-handshake certificate request with TLS 1.3. Returns 'False'+-- if the request was impossible, i.e. the remote client supports+-- 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. requestCertificate :: Context -> IO Bool requestCertificate ctx =- withWriteLock ctx $- checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx+ checkValid ctx >> doRequestCertificate_ (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.-postHandshakeAuthWith :: Context -> Handshake13 -> IO ()-postHandshakeAuthWith ctx hs =+-- | 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 -> Handshake13R -> IO ()+postHandshakeAuthWith ctx hb = withWriteLock ctx $ handleException ctx $- doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs+ doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hb
Network/TLS/QUIC.hs view
@@ -68,12 +68,15 @@ defaultSupported, ) where +import Data.Default (def)+ import Network.TLS.Backend import Network.TLS.Context import Network.TLS.Context.Internal import Network.TLS.Core import Network.TLS.Crypto (hashDigestSize) import Network.TLS.Crypto.Types+import Network.TLS.Extension import Network.TLS.Extra.Cipher import Network.TLS.Handshake.Common import Network.TLS.Handshake.Control@@ -81,14 +84,12 @@ import Network.TLS.Handshake.State13 import Network.TLS.Imports import Network.TLS.KeySchedule (hkdfExpandLabel, hkdfExtract)-import Network.TLS.Parameters+import Network.TLS.Parameters hiding (defaultSupported) import Network.TLS.Record.Layer import Network.TLS.Record.State import Network.TLS.Struct import Network.TLS.Types -import Data.Default.Class- nullBackend :: Backend nullBackend = Backend@@ -115,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@@ -170,10 +171,13 @@ tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ())- , ctxFragmentSize = Nothing+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks@@ -190,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) @@ -200,10 +204,13 @@ tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync- , ctxFragmentSize = Nothing+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks@@ -215,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)@@ -246,9 +253,9 @@ def { supportedVersions = [TLS13] , supportedCiphers =- [ cipher_TLS13_AES256GCM_SHA384- , cipher_TLS13_AES128GCM_SHA256- , cipher_TLS13_AES128CCM_SHA256+ [ cipher13_AES_256_GCM_SHA384+ , cipher13_AES_128_GCM_SHA256+ , cipher13_AES_128_CCM_SHA256 ] , supportedGroups = [X25519, X448, P256, P384, P521] }
− Network/TLS/Receiving.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Receiving (- processPacket,- processPacket13,-) where--import Control.Concurrent.MVar-import Control.Monad.State.Strict--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Handshake.State-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Record-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Util-import Network.TLS.Wire--processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet)-processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment-processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment))-processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of- Left err -> return $ Left err- Right _ -> do- switchRxEncryption ctx- return $ Right ChangeCipherSpec-processPacket ctx (Record ProtocolType_Handshake ver fragment) = do- keyxchg <-- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)- usingState ctx $ do- let currentParams =- CurrentParams- { cParamsVersion = ver- , cParamsKeyXchgType = keyxchg- }- -- get back the optional continuation, and parse as many handshake record as possible.- mCont <- gets stHandshakeRecordCont- modify (\st -> st{stHandshakeRecordCont = Nothing})- hss <- parseMany currentParams mCont (fragmentGetBytes fragment)- return $ Handshake hss- where- parseMany currentParams mCont bs =- case fromMaybe decodeHandshakeRecord mCont bs of- GotError err -> throwError err- GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont = Just cont}) >> return []- GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake currentParams ty content- GotSuccessRemaining (ty, content) left ->- case decodeHandshake currentParams ty content of- Left err -> throwError err- Right hh -> (hh :) <$> parseMany currentParams Nothing left-processPacket _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")--switchRxEncryption :: Context -> IO ()-switchRxEncryption ctx =- usingHState ctx (gets hstPendingRxState) >>= \rx ->- modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx)--------------------------------------------------------------------processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)-processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13-processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment-processPacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))-processPacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do- mCont <- gets stHandshakeRecordCont13- modify (\st -> st{stHandshakeRecordCont13 = Nothing})- hss <- parseMany mCont (fragmentGetBytes fragment)- return $ Handshake13 hss- where- parseMany mCont bs =- case fromMaybe decodeHandshakeRecord13 mCont bs of- GotError err -> throwError err- GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []- GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake13 ty content- GotSuccessRemaining (ty, content) left ->- case decodeHandshake13 ty content of- Left err -> throwError err- Right hh -> (hh :) <$> parseMany Nothing left-processPacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
Network/TLS/Record.hs view
@@ -15,12 +15,11 @@ rawToRecord, recordToHeader, Plaintext,- Compressed, Ciphertext, - -- * Engage and disengage from the record layer- engageRecord,- disengageRecord,+ -- * Encrypt and decrypt from the record layer+ encryptRecord,+ decryptRecord, -- * State tracking RecordM,@@ -31,7 +30,7 @@ setRecordIV, ) where -import Network.TLS.Record.Disengage-import Network.TLS.Record.Engage+import Network.TLS.Record.Decrypt+import Network.TLS.Record.Encrypt import Network.TLS.Record.State import Network.TLS.Record.Types
+ Network/TLS/Record/Decrypt.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.Record.Decrypt (+ decryptRecord,+) where++import Control.Monad.State.Strict+import Crypto.Cipher.Types (AuthTag (..))+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Crypto+import Network.TLS.ErrT+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Record.Types+import Network.TLS.Struct+import Network.TLS.Util+import Network.TLS.Wire++decryptRecord :: Record Ciphertext -> Int -> RecordM (Record Plaintext)+decryptRecord record@(Record ct ver fragment) lim = do+ st <- get+ case stCipher st of+ Nothing -> noDecryption+ _ -> do+ recOpts <- getRecordOptions+ let mver = recordVersion recOpts+ if recordTLS13 recOpts+ then decryptData13 mver (fragmentGetBytes fragment) st+ else onRecordFragment record $ fragmentUncipher $ \e ->+ decryptData mver record e st lim+ where+ noDecryption = onRecordFragment record $ fragmentUncipher $ checkPlainLimit lim+ decryptData13 mver e st = case ct of+ ProtocolType_AppData -> do+ inner <- decryptData mver record e st (lim + 1)+ case unInnerPlaintext inner of+ Left message -> throwError $ Error_Protocol message UnexpectedMessage+ Right (ct', d) -> return $ Record ct' ver $ fragmentPlaintext d+ ProtocolType_ChangeCipherSpec -> noDecryption+ ProtocolType_Alert -> noDecryption+ _ ->+ throwError $ Error_Protocol "illegal plain text" UnexpectedMessage++unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)+unInnerPlaintext inner =+ case B.unsnoc dc of+ Nothing -> Left $ unknownContentType13 (0 :: Word8)+ Just (bytes, c)+ | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes ->+ Left ("empty " ++ show (ProtocolType c) ++ " record disallowed")+ | 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++-- | Check a decrypted record.+--+-- The first 'Bool' is what the lengths already said: 'False' when the padding+-- length the record claims cannot be one. 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+ -- 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)++ -- 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 = fromIntegral (B.length pad - 1)+ -- Every octet, and no allocation of a pattern to compare against:+ -- B.all stops at the first wrong octet, and replicating the+ -- pattern costs time in proportion to a length the peer chose.+ return $ B.foldl' (\acc w -> acc .|. (w `xor` b)) 0 pad == 0++ unless (lengthValid &&! macValid &&! paddingValid) $+ throwError $+ Error_Protocol "bad record mac Stream/Block" BadRecordMac++ return $ cipherDataContent cdata++checkPlainLimit :: Int -> ByteString -> RecordM ByteString+checkPlainLimit lim plain+ | len > lim =+ throwError $+ Error_Protocol+ ( "plaintext exceeding record size limit: "+ ++ show len+ ++ " > "+ ++ show lim+ )+ RecordOverflow+ | otherwise = return plain+ where+ len = B.length plain++decryptData+ :: Version+ -> Record Ciphertext+ -> ByteString+ -> RecordState+ -> Int+ -> RecordM ByteString+decryptData ver record econtent tst lim =+ decryptOf (cstKey cst) >>= checkPlainLimit lim+ where+ cipher = fromJust $ stCipher tst+ bulk = cipherBulk cipher+ cst = stCryptState tst+ macSize = hashDigestSize $ cipherHash cipher+ 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_Protocol+ "encrypted content too small for encryption parameters"+ BadRecordMac++ decryptOf :: BulkState -> RecordM ByteString+ decryptOf (BulkStateBlock decryptF) = do+ let minContent = bulkIVSize bulk + max (macSize + 1) blockSize++ -- check if we have enough bytes to cover the minimum for this cipher+ when+ ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent)+ sanityCheckError++ {- update IV -}+ (iv, econtent') <-+ get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)+ let (content', iv') = decryptF iv econtent'+ modify' $ \txs -> txs{stCryptState = cst{cstIV = iv'}}++ -- 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+ (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)+ getCipherData+ record+ lengthValid+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just (padding, blockSize)+ }+ decryptOf (BulkStateStream (BulkStream decryptF)) = do+ -- check if we have enough bytes to cover the minimum for this cipher+ when (econtentLen < macSize) sanityCheckError++ let (content', bulkStream') = decryptF econtent+ {- update Ctx -}+ let contentlen = B.length content' - macSize+ (content, mac) <- get2i content' (contentlen, macSize)+ modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}+ getCipherData+ record+ True+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ decryptOf (BulkStateAEAD decryptF) = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk+ cipherLen = econtentLen - authTagLen - nonceExpLen++ -- check if we have enough bytes to cover the minimum for this cipher+ when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError++ (enonce, econtent', authTag) <-+ get3o econtent (nonceExpLen, cipherLen, authTagLen)+ let encodedSeq = encodeWord64 $ msSequence $ stMacState tst+ iv = cstIV (stCryptState tst)+ ivlen = B.length iv+ Header typ v _ = recordToHeader record+ hdrLen = if ver >= TLS13 then econtentLen else cipherLen+ hdr = Header typ v $ fromIntegral hdrLen+ ad+ | ver >= TLS13 = encodeHeader hdr+ | otherwise = B.concat [encodedSeq, encodeHeader hdr]+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce+ | nonceExpLen == 0 = BA.xor iv sqnc+ | otherwise = iv `B.append` enonce+ (content, authTag2) = decryptF nonce econtent' ad++ when (AuthTag (convert authTag) /= authTag2) $+ throwError $+ Error_Protocol "bad record mac on AEAD" BadRecordMac++ modify' incrRecordState+ return content+ decryptOf BulkStateUninitialized =+ throwError $ Error_Protocol "decrypt state uninitialized" InternalError++ -- 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_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+ -- externally as integrity failures, i.e. BadRecordMac+ get3i s ls =+ 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)
− Network/TLS/Record/Disengage.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Record.Disengage (- disengageRecord,-) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)-import qualified Data.ByteString as B--import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Crypto-import Network.TLS.ErrT-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Struct-import Network.TLS.Util-import Network.TLS.Wire--disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext)-disengageRecord = decryptRecord >=> uncompressRecord--uncompressRecord :: Record Compressed -> RecordM (Record Plaintext)-uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->- withCompression $ compressionInflate bytes--decryptRecord :: Record Ciphertext -> RecordM (Record Compressed)-decryptRecord record@(Record ct ver fragment) = do- st <- get- case stCipher st of- Nothing -> noDecryption- _ -> do- recOpts <- getRecordOptions- let mver = recordVersion recOpts- if recordTLS13 recOpts- then decryptData13 mver (fragmentGetBytes fragment) st- else onRecordFragment record $ fragmentUncipher $ \e ->- decryptData mver record e st- where- noDecryption = onRecordFragment record $ fragmentUncipher return- decryptData13 mver e st = case ct of- ProtocolType_AppData -> do- inner <- decryptData mver record e st- case unInnerPlaintext inner of- Left message -> throwError $ Error_Protocol message UnexpectedMessage- Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d)- ProtocolType_ChangeCipherSpec -> noDecryption- ProtocolType_Alert -> noDecryption- _ ->- throwError $ Error_Protocol "illegal plain text" UnexpectedMessage--unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)-unInnerPlaintext inner =- case B.unsnoc dc of- Nothing -> Left $ unknownContentType13 (0 :: Word8)- Just (bytes, c)- | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes ->- Left ("empty " ++ show (ProtocolType c) ++ " record disallowed")- | 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 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-- unless (macValid &&! paddingValid) $- throwError $- Error_Protocol "bad record mac Stream/Block" BadRecordMac-- return $ cipherDataContent cdata--decryptData- :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString-decryptData ver record econtent tst = decryptOf (cstKey cst)- where- cipher = fromJust $ stCipher tst- bulk = cipherBulk cipher- cst = stCryptState tst- macSize = hashDigestSize $ cipherHash cipher- blockSize = bulkBlockSize bulk- econtentLen = B.length econtent-- sanityCheckError =- throwError- (Error_Packet "encrypted content too small for encryption parameters")-- decryptOf :: BulkState -> RecordM ByteString- decryptOf (BulkStateBlock decryptF) = do- let minContent = bulkIVSize bulk + max (macSize + 1) blockSize-- -- check if we have enough bytes to cover the minimum for this cipher- when- ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent)- sanityCheckError-- {- update IV -}- (iv, econtent') <-- get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)- 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)- }- decryptOf (BulkStateStream (BulkStream decryptF)) = do- -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < macSize) sanityCheckError-- let (content', bulkStream') = decryptF econtent- {- update Ctx -}- let contentlen = B.length content' - macSize- (content, mac) <- get2i content' (contentlen, macSize)- modify $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}- getCipherData- record- CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }- decryptOf (BulkStateAEAD decryptF) = do- let authTagLen = bulkAuthTagLen bulk- nonceExpLen = bulkExplicitIV bulk- cipherLen = econtentLen - authTagLen - nonceExpLen-- -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError-- (enonce, econtent', authTag) <-- get3o econtent (nonceExpLen, cipherLen, authTagLen)- let encodedSeq = encodeWord64 $ msSequence $ stMacState tst- iv = cstIV (stCryptState tst)- ivlen = B.length iv- Header typ v _ = recordToHeader record- hdrLen = if ver >= TLS13 then econtentLen else cipherLen- hdr = Header typ v $ fromIntegral hdrLen- ad- | ver >= TLS13 = encodeHeader hdr- | otherwise = B.concat [encodedSeq, encodeHeader hdr]- sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq- nonce- | nonceExpLen == 0 = B.xor iv sqnc- | otherwise = iv `B.append` enonce- (content, authTag2) = decryptF nonce econtent' ad-- when (AuthTag (B.convert authTag) /= authTag2) $- throwError $- Error_Protocol "bad record mac on AEAD" BadRecordMac-- modify incrRecordState- return content- decryptOf BulkStateUninitialized =- throwError $ Error_Protocol "decrypt state uninitialized" InternalError-- -- handling of outer format can report errors with Error_Packet- get3o s ls =- maybe (throwError $ Error_Packet "record bad format") 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- -- externally as integrity failures, i.e. BadRecordMac- get3i s ls =- 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)
+ Network/TLS/Record/Encrypt.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- Engage a record into the Record layer.+-- The record is compressed, added some integrity field, then encrypted.+--+-- Starting with TLS v1.3, only the "null" compression method is negotiated in+-- the handshake, so the compression step will be a no-op. Integrity and+-- encryption are performed using an AEAD cipher only.+module Network.TLS.Record.Encrypt (+ encryptRecord,+) where++import Control.Monad.State.Strict+import Crypto.Cipher.Types (AuthTag (..))+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Record.Types+import Network.TLS.Wire++-- when Tx Encrypted is set, we pass the data through encryptContent, otherwise+-- we just return the compress payload directly as the ciphered one+--+encryptRecord :: Record Plaintext -> RecordM (Record Ciphertext)+encryptRecord record@(Record ct ver fragment) = do+ st <- get+ case stCipher st of+ Nothing -> noEncryption+ _ -> do+ recOpts <- getRecordOptions+ if recordTLS13 recOpts+ then encryptContent13+ else onRecordFragment record $ fragmentCipher (encryptContent False record)+ where+ noEncryption = onRecordFragment record $ fragmentCipher return+ encryptContent13+ | ct == ProtocolType_ChangeCipherSpec = noEncryption+ | otherwise = do+ let bytes = fragmentGetBytes fragment+ fragment' = fragmentPlaintext $ innerPlaintext ct bytes+ record' = Record ProtocolType_AppData ver fragment'+ onRecordFragment record' $ fragmentCipher (encryptContent True record')++innerPlaintext :: ProtocolType -> ByteString -> ByteString+innerPlaintext (ProtocolType c) bytes = runPut $ do+ putBytes bytes+ putWord8 c -- non zero!+ -- fixme: zeros padding++encryptContent :: Bool -> Record Plaintext -> ByteString -> RecordM ByteString+encryptContent tls13 record content = do+ cst <- getCryptState+ bulk <- getBulk+ case cstKey cst of+ BulkStateBlock encryptF -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptBlock encryptF content' bulk+ BulkStateStream encryptF -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptStream encryptF content'+ BulkStateAEAD encryptF ->+ encryptAead tls13 bulk encryptF content record+ BulkStateUninitialized ->+ return content++encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString+encryptBlock encryptF content bulk = do+ cst <- getCryptState+ let blockSize = fromIntegral $ bulkBlockSize bulk+ let msg_len = B.length content+ let padding =+ if blockSize > 0+ then+ let padbyte = blockSize - (msg_len `mod` blockSize)+ in let padbyte' = if padbyte == 0 then blockSize else padbyte+ in B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else B.empty++ let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding]++ return $ B.concat [cstIV cst, e]++encryptStream :: BulkStream -> ByteString -> RecordM ByteString+encryptStream (BulkStream encryptF) content = do+ cst <- getCryptState+ let (!e, !newBulkStream) = encryptF content+ modify' $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}+ return e++encryptAead+ :: Bool+ -> Bulk+ -> BulkAEAD+ -> ByteString+ -> Record Plaintext+ -> RecordM ByteString+encryptAead tls13 bulk encryptF content record = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk+ cst <- getCryptState+ encodedSeq <- encodeWord64 <$> getMacSequence++ let iv = cstIV cst+ ivlen = B.length iv+ Header typ v plainLen = recordToHeader record+ hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen+ hdr = Header typ v hdrLen+ ad+ | tls13 = encodeHeader hdr+ | otherwise = B.concat [encodedSeq, encodeHeader hdr]+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce+ | nonceExpLen == 0 = BA.xor iv sqnc+ | otherwise = B.concat [iv, encodedSeq]+ (e, AuthTag authtag) = encryptF nonce content ad+ econtent+ | nonceExpLen == 0 = e `B.append` convert authtag+ | otherwise = B.concat [encodedSeq, e, convert authtag]+ modify' incrRecordState+ return econtent++getCryptState :: RecordM CryptState+getCryptState = stCryptState <$> get
− Network/TLS/Record/Engage.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- |--- Engage a record into the Record layer.--- The record is compressed, added some integrity field, then encrypted.------ Starting with TLS v1.3, only the "null" compression method is negotiated in--- the handshake, so the compression step will be a no-op. Integrity and--- encryption are performed using an AEAD cipher only.-module Network.TLS.Record.Engage (- engageRecord,-) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag (..))--import qualified Data.ByteArray as B (convert, xor)-import qualified Data.ByteString as B-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Wire--engageRecord :: Record Plaintext -> RecordM (Record Ciphertext)-engageRecord = compressRecord >=> encryptRecord--compressRecord :: Record Plaintext -> RecordM (Record Compressed)-compressRecord record =- onRecordFragment record $ fragmentCompress $ \bytes -> do- withCompression $ compressionDeflate bytes---- when Tx Encrypted is set, we pass the data through encryptContent, otherwise--- we just return the compress payload directly as the ciphered one----encryptRecord :: Record Compressed -> RecordM (Record Ciphertext)-encryptRecord record@(Record ct ver fragment) = do- st <- get- case stCipher st of- Nothing -> noEncryption- _ -> do- recOpts <- getRecordOptions- if recordTLS13 recOpts- then encryptContent13- else onRecordFragment record $ fragmentCipher (encryptContent False record)- where- noEncryption = onRecordFragment record $ fragmentCipher return- encryptContent13- | ct == ProtocolType_ChangeCipherSpec = noEncryption- | otherwise = do- let bytes = fragmentGetBytes fragment- fragment' = fragmentCompressed $ innerPlaintext ct bytes- record' = Record ProtocolType_AppData ver fragment'- onRecordFragment record' $ fragmentCipher (encryptContent True record')--innerPlaintext :: ProtocolType -> ByteString -> ByteString-innerPlaintext (ProtocolType c) bytes = runPut $ do- putBytes bytes- putWord8 c -- non zero!- -- fixme: zeros padding--encryptContent :: Bool -> Record Compressed -> ByteString -> RecordM ByteString-encryptContent tls13 record content = do- cst <- getCryptState- bulk <- getBulk- case cstKey cst of- BulkStateBlock encryptF -> do- digest <- makeDigest (recordToHeader record) content- let content' = B.concat [content, digest]- encryptBlock encryptF content' bulk- BulkStateStream encryptF -> do- digest <- makeDigest (recordToHeader record) content- let content' = B.concat [content, digest]- encryptStream encryptF content'- BulkStateAEAD encryptF ->- encryptAead tls13 bulk encryptF content record- BulkStateUninitialized ->- return content--encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString-encryptBlock encryptF content bulk = do- cst <- getCryptState- let blockSize = fromIntegral $ bulkBlockSize bulk- let msg_len = B.length content- let padding =- if blockSize > 0- then- let padbyte = blockSize - (msg_len `mod` blockSize)- in let padbyte' = if padbyte == 0 then blockSize else padbyte- in B.replicate padbyte' (fromIntegral (padbyte' - 1))- else B.empty-- let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding]-- return $ B.concat [cstIV cst, e]--encryptStream :: BulkStream -> ByteString -> RecordM ByteString-encryptStream (BulkStream encryptF) content = do- cst <- getCryptState- let (!e, !newBulkStream) = encryptF content- modify $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}- return e--encryptAead- :: Bool- -> Bulk- -> BulkAEAD- -> ByteString- -> Record Compressed- -> RecordM ByteString-encryptAead tls13 bulk encryptF content record = do- let authTagLen = bulkAuthTagLen bulk- nonceExpLen = bulkExplicitIV bulk- cst <- getCryptState- encodedSeq <- encodeWord64 <$> getMacSequence-- let iv = cstIV cst- ivlen = B.length iv- Header typ v plainLen = recordToHeader record- hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen- hdr = Header typ v hdrLen- ad- | tls13 = encodeHeader hdr- | otherwise = B.concat [encodedSeq, encodeHeader hdr]- sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq- nonce- | nonceExpLen == 0 = B.xor iv sqnc- | otherwise = B.concat [iv, encodedSeq]- (e, AuthTag authtag) = encryptF nonce content ad- econtent- | nonceExpLen == 0 = e `B.append` B.convert authtag- | otherwise = B.concat [encodedSeq, e, B.convert authtag]- modify incrRecordState- return econtent--getCryptState :: RecordM CryptState-getCryptState = stCryptState <$> get
Network/TLS/Record/Layer.hs view
@@ -18,10 +18,10 @@ -> RecordLayer [(ann, ByteString)] newTransparentRecordLayer get send recv = RecordLayer- { recordEncode = transparentEncodeRecord get+ { recordEncode12 = transparentEncodeRecord get , recordEncode13 = transparentEncodeRecord get , recordSendBytes = transparentSendBytes send- , recordRecv = \ctx _ -> transparentRecvRecord recv ctx+ , recordRecv12 = transparentRecvRecord recv , recordRecv13 = transparentRecvRecord recv }
− Network/TLS/Record/Reading.hs
@@ -1,103 +0,0 @@--- | TLS record layer in Rx direction-module Network.TLS.Record.Reading (- recvRecord,- recvRecord13,-) where--import qualified Data.ByteString as B--import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record-import Network.TLS.Struct--------------------------------------------------------------------exceeds :: Integral ty => Context -> Int -> ty -> Bool-exceeds ctx overhead actual =- case ctxFragmentSize ctx of- Nothing -> False- Just sz -> fromIntegral actual > sz + overhead--getRecord- :: Context- -> Int- -> Header- -> ByteString- -> IO (Either TLSError (Record Plaintext))-getRecord ctx appDataOverhead header@(Header pt _ _) content = do- withLog ctx $ \logging -> loggingIORecv logging header content- runRxRecordState ctx $ do- r <- decodeRecordM header content- let Record _ _ fragment = r- when (exceeds ctx overhead $ B.length (fragmentGetBytes fragment)) $- throwError contentSizeExceeded- return r- where- overhead = if pt == ProtocolType_AppData then appDataOverhead else 0--decodeRecordM :: Header -> ByteString -> RecordM (Record Plaintext)-decodeRecordM header content = disengageRecord erecord- where- erecord = rawToRecord header (fragmentCiphertext content)--contentSizeExceeded :: TLSError-contentSizeExceeded = Error_Protocol "record content exceeding maximum size" RecordOverflow---------------------------------------------------------------------- | recvRecord receive a full TLS record (header + data), from the other side.------ The record is disengaged from the record layer-recvRecord- :: Context- -- ^ TLS context- -> Int- -- ^ number of AppData bytes to accept above normal maximum size- -> IO (Either TLSError (Record Plaintext))-recvRecord ctx appDataOverhead =- readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)- where- recvLengthE = either (return . Left) recvLength-- recvLength header@(Header _ _ readlen)- | exceeds ctx 2048 readlen = return $ Left maximumSizeExceeded- | otherwise =- readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx appDataOverhead header)--recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))-recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)- where- recvLengthE = either (return . Left) recvLength- recvLength header@(Header _ _ readlen)- | exceeds ctx 256 readlen = return $ Left maximumSizeExceeded- | otherwise =- readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx 0 header)--maximumSizeExceeded :: TLSError-maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow--------------------------------------------------------------------readExactBytes :: Context -> Int -> IO (Either TLSError ByteString)-readExactBytes ctx sz = do- hdrbs <- contextRecv ctx sz- if B.length hdrbs == sz- then return $ Right hdrbs- else do- setEOF ctx- return . Left $- if B.null hdrbs- then Error_EOF- else- Error_Packet- ( "partial packet: expecting "- ++ show sz- ++ " bytes, got: "- ++ show (B.length hdrbs)- )
+ Network/TLS/Record/Recv.hs view
@@ -0,0 +1,133 @@+-- | TLS record layer in Rx direction+module Network.TLS.Record.Recv (+ recvRecord12,+ recvRecord13,+) where++import qualified Data.ByteString as B++import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct+import Network.TLS.Types++----------------------------------------------------------------++getMyPlainLimit :: Context -> IO Int+getMyPlainLimit ctx = do+ msiz <- getMyRecordLimit ctx+ return $ case msiz of+ Nothing -> defaultRecordSizeLimit+ Just siz -> siz++getRecord+ :: Context+ -> Header+ -> ByteString+ -> IO (Either TLSError (Record Plaintext))+getRecord ctx header content = do+ withLog ctx $ \logging -> loggingIORecv logging header content+ lim <- getMyPlainLimit ctx+ runRxRecordState ctx $ do+ let erecord = rawToRecord header $ fragmentCiphertext content+ decryptRecord erecord lim++----------------------------------------------------------------++exceedsTLSCiphertext :: Int -> Word16 -> Bool+exceedsTLSCiphertext overhead actual =+ -- In TLS 1.3, overhead is included one more byte for content type.+ fromIntegral actual > defaultRecordSizeLimit + overhead++-- | recvRecord receive a full TLS record (header + data), from the other side.+--+-- The record is disengaged from the record layer+recvRecord12+ :: Context+ -- ^ TLS context+ -> IO (Either TLSError (Record Plaintext))+recvRecord12 ctx =+ readExactBytes ctx 5+ >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType))+ where+ recvLengthE = either (return . Left) recvLength++ recvLength header@(Header _ _ readlen) = do+ -- RFC 5246 Section 7.2.2+ -- A TLSCiphertext record was received that had a length more+ -- than 2^14+2048 bytes, or a record decrypted to a+ -- TLSCompressed record with more than 2^14+1024 bytes. This+ -- message is always fatal and should never be observed in+ -- communication between proper implementations (except when+ -- messages were corrupted in the network).+ if exceedsTLSCiphertext 2048 readlen+ then return $ Left maximumSizeExceeded+ else+ readExactBytes ctx (fromIntegral readlen)+ >>= either (return . Left) (getRecord ctx header)++recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))+recvRecord13 ctx =+ readExactBytes ctx 5+ >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType))+ where+ recvLengthE = either (return . Left) recvLength+ recvLength header@(Header _ _ readlen) = do+ -- RFC 8446 Section 5.2:+ -- An AEAD algorithm used in TLS 1.3 MUST NOT produce an+ -- expansion greater than 255 octets. An endpoint that+ -- receives a record from its peer with TLSCiphertext.length+ -- larger than 2^14 + 256 octets MUST terminate the connection+ -- with a "record_overflow" alert. This limit is derived from+ -- the maximum TLSInnerPlaintext length of 2^14 octets + 1+ -- octet for ContentType + the maximum AEAD expansion of 255+ -- octets.+ if exceedsTLSCiphertext 256 readlen+ then return $ Left maximumSizeExceeded+ else+ readExactBytes ctx (fromIntegral readlen)+ >>= either (return . Left) (getRecord ctx header)++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+ ]++----------------------------------------------------------------++readExactBytes :: Context -> Int -> IO (Either TLSError ByteString)+readExactBytes ctx sz = do+ hdrbs <- contextRecv ctx sz+ if B.length hdrbs == sz+ then return $ Right hdrbs+ else do+ setEOF ctx+ return . Left $+ if B.null hdrbs+ then Error_EOF+ else+ Error_Packet+ ( "partial packet: expecting "+ ++ show sz+ ++ " bytes, got: "+ ++ show (B.length hdrbs)+ )
+ Network/TLS/Record/Send.hs view
@@ -0,0 +1,61 @@+-- | TLS record layer in Tx direction+module Network.TLS.Record.Send (+ encodeRecord12,+ encodeRecord13,+ sendBytes,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct++encodeRecordM :: Record Plaintext -> RecordM ByteString+encodeRecordM record = do+ erecord <- encryptRecord record+ let (hdr, content) = recordToRaw erecord+ return $ B.concat [encodeHeader hdr, content]++----------------------------------------------------------------++encodeRecord12 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord12 ctx = prepareRecord12 ctx . encodeRecordM++-- before TLS 1.1, the block cipher IV is made of the residual of the previous block,+-- so we use cstIV as is, however in other case we generate an explicit IV+prepareRecord12 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord12 ctx f = do+ txState <- readMVar $ ctxTxRecordState ctx+ let sz = case stCipher txState of+ Nothing -> 0+ Just cipher ->+ if hasRecordIV $ bulkF $ cipherBulk cipher+ then bulkIVSize $ cipherBulk cipher+ else 0 -- to not generate IV+ if sz > 0+ then do+ newIV <- getStateRNG ctx sz+ runTxRecordState ctx (modify' (setRecordIV newIV) >> f)+ else runTxRecordState ctx f++----------------------------------------------------------------++encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM++prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord13 = runTxRecordState++----------------------------------------------------------------++sendBytes :: Context -> ByteString -> IO ()+sendBytes ctx dataToSend = do+ withLog ctx $ \logging -> loggingIOSent logging dataToSend+ contextSend ctx dataToSend
Network/TLS/Record/State.hs view
@@ -22,6 +22,7 @@ ) where import Control.Monad.State.Strict+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher@@ -36,10 +37,10 @@ data CryptState = CryptState { cstKey :: BulkState- , cstIV :: ByteString+ , cstIV :: IV , -- In TLS 1.2 or earlier, this holds mac secret. -- In TLS 1.3, this holds application traffic secret N.- cstMacSecret :: ByteString+ cstMacSecret :: Secret } deriving (Show) @@ -130,7 +131,7 @@ { stCipher = Nothing , stCompression = nullCompression , stCryptLevel = CryptInitial- , stCryptState = CryptState BulkStateUninitialized B.empty B.empty+ , stCryptState = CryptState BulkStateUninitialized B.empty BA.empty , stMacState = MacState 0 } @@ -153,7 +154,7 @@ :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest _ver tstate hdr content = (digest, incrRecordState tstate) where- digest = macF (cstMacSecret cst) msg+ digest = BA.convert $ macF (cstMacSecret cst) msg cst = stCryptState tstate cipher = fromJust $ stCipher tstate hashA = cipherHash cipher
Network/TLS/Record/Types.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE EmptyDataDecls #-} -- | The Record Protocol takes messages to be transmitted, fragments--- the data into manageable blocks, optionally compresses the data,--- applies a MAC, encrypts, and transmits the result. Received data--- is decrypted, verified, decompressed, reassembled, and then--- delivered to higher-level clients.+-- the data into manageable blocks. applies a MAC, encrypts, and+-- transmits the result. Received data is decrypted, verified,+-- reassembled, and then delivered to higher-level clients. module Network.TLS.Record.Types ( Header (..), ProtocolType (..),@@ -17,18 +16,14 @@ Fragment, fragmentGetBytes, fragmentPlaintext,- fragmentCompressed, fragmentCiphertext, Plaintext,- Compressed, Ciphertext, -- * manipulate record onRecordFragment,- fragmentCompress, fragmentCipher, fragmentUncipher,- fragmentUncompress, -- * serialize record rawToRecord,@@ -37,6 +32,7 @@ ) where import qualified Data.ByteString as B+ import Network.TLS.Imports import Network.TLS.Record.State import Network.TLS.Struct@@ -48,15 +44,11 @@ deriving (Show, Eq) data Plaintext-data Compressed data Ciphertext fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes -fragmentCompressed :: ByteString -> Fragment Compressed-fragmentCompressed bytes = Fragment bytes- fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes @@ -68,33 +60,19 @@ :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b --- | turn a plaintext record into a compressed record using the compression function supplied-fragmentCompress- :: (ByteString -> RecordM ByteString)- -> Fragment Plaintext- -> RecordM (Fragment Compressed)-fragmentCompress f = fragmentMap f- -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (ByteString -> RecordM ByteString)- -> Fragment Compressed+ -> Fragment Plaintext -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f --- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied+-- | turn a ciphertext fragment into a plaintext fragment using the cipher function supplied fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext- -> RecordM (Fragment Compressed)-fragmentUncipher f = fragmentMap f---- | turn a compressed fragment into a plaintext fragment using the decompression function supplied-fragmentUncompress- :: (ByteString -> RecordM ByteString)- -> Fragment Compressed -> RecordM (Fragment Plaintext)-fragmentUncompress f = fragmentMap f+fragmentUncipher f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, ByteString)
− Network/TLS/Record/Writing.hs
@@ -1,59 +0,0 @@--- | TLS record layer in Tx direction-module Network.TLS.Record.Writing (- encodeRecord,- encodeRecord13,- sendBytes,-) where--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record-import Network.TLS.Struct--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B--encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString)-encodeRecord ctx = prepareRecord ctx . encodeRecordM---- before TLS 1.1, the block cipher IV is made of the residual of the previous block,--- so we use cstIV as is, however in other case we generate an explicit IV-prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord ctx f = do- txState <- readMVar $ ctxTxRecordState ctx- let sz = case stCipher txState of- Nothing -> 0- Just cipher ->- if hasRecordIV $ bulkF $ cipherBulk cipher- then bulkIVSize $ cipherBulk cipher- else 0 -- to not generate IV- if sz > 0- then do- newIV <- getStateRNG ctx sz- runTxRecordState ctx (modify (setRecordIV newIV) >> f)- else runTxRecordState ctx f--encodeRecordM :: Record Plaintext -> RecordM ByteString-encodeRecordM record = do- erecord <- engageRecord record- let (hdr, content) = recordToRaw erecord- return $ B.concat [encodeHeader hdr, content]--------------------------------------------------------------------encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)-encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM--prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord13 = runTxRecordState--------------------------------------------------------------------sendBytes :: Context -> ByteString -> IO ()-sendBytes ctx dataToSend = do- withLog ctx $ \logging -> loggingIOSent logging dataToSend- contextSend ctx dataToSend
− Network/TLS/Sending.hs
@@ -1,124 +0,0 @@-module Network.TLS.Sending (- encodePacket12,- encodePacket13,- updateHandshake12,- updateHandshake13,-) where--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B-import Data.IORef--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Parameters-import Network.TLS.Record-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types (Role (..))-import Network.TLS.Util---- | encodePacket transform a packet into marshalled data related to current state--- and updating state on the go-encodePacket12- :: Monoid bytes- => Context- -> RecordLayer bytes- -> Packet- -> IO (Either TLSError bytes)-encodePacket12 ctx recordLayer pkt = do- (ver, _) <- decideRecordVersion ctx- let pt = packetType pkt- mkRecord bs = Record pt ver (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments12 ctx len pkt- bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer ctx)- when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx- return bs---- Decompose handshake packets into fragments of the specified length. AppData--- packets are not fragmented here but by callers of sendPacket, so that the--- empty-packet countermeasure may be applied to each fragment independently.-packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]-packetToFragments12 ctx len (Handshake hss) =- getChunks len . B.concat <$> mapM (updateHandshake12 ctx) hss-packetToFragments12 _ _ (Alert a) = return [encodeAlerts a]-packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]-packetToFragments12 _ _ (AppData x) = return [x]--switchTxEncryption :: Context -> IO ()-switchTxEncryption ctx = do- tx <- usingHState ctx (fromJust <$> gets hstPendingTxState)- (ver, role) <- usingState_ ctx $ do- v <- getVersion- r <- getRole- return (v, r)- liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx)- -- set empty packet counter measure if condition are met- when- ( ver <= TLS10- && role == ClientRole- && isCBC tx- && supportedEmptyPacket (ctxSupported ctx)- )- $ liftIO- $ writeIORef (ctxNeedEmptyPacket ctx) True- where- isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)--updateHandshake12 :: Context -> Handshake -> IO ByteString-updateHandshake12 ctx hs = do- usingHState ctx $ do- when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded- when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded- return encoded- where- encoded = encodeHandshake hs--------------------------------------------------------------------encodePacket13- :: Monoid bytes- => Context- -> RecordLayer bytes- -> Packet13- -> IO (Either TLSError bytes)-encodePacket13 ctx recordLayer pkt = do- let pt = contentType pkt- mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments13 ctx len pkt- fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)--packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]-packetToFragments13 ctx len (Handshake13 hss) =- getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss-packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]-packetToFragments13 _ _ (AppData13 x) = return [x]-packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]--updateHandshake13 :: Context -> Handshake13 -> IO ByteString-updateHandshake13 ctx hs- | isIgnored hs = return encoded- | otherwise = usingHState ctx $ do- when (isHRR hs) wrapAsMessageHash13- updateHandshakeDigest encoded- addHandshakeMessage encoded- return encoded- where- encoded = encodeHandshake13 hs-- isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand- isHRR _ = False-- isIgnored NewSessionTicket13{} = True- isIgnored KeyUpdate13{} = True- isIgnored _ = False
Network/TLS/Session.hs view
@@ -5,18 +5,20 @@ import Network.TLS.Types --- | A session manager+-- | A session manager.+-- In the server side, all fields are used.+-- In the client side, only 'sessionEstablish' is used. data SessionManager = SessionManager { sessionResume :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ 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'.- , sessionEstablish :: SessionID -> SessionData -> IO (Maybe Ticket)- -- ^ Used TLS 1.2\/1.3 servers\/clients to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket'. In the client side, 'Nothing' should be returned. For clients, only this field should be set with 'noSessionManager'.- , sessionInvalidate :: SessionID -> IO ()- -- ^ Used TLS 1.2\/1.3 servers to delete 'SessionData' with 'SessionID' if @sessionUseTicket@ is 'True'.+ , 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 ()+ -- ^ Used TLS 1.2 servers to delete 'SessionData' with 'SessionID' on errors. , sessionUseTicket :: Bool- -- ^ Used on TLS 1.2 servers to decide to use 'SessionID' or 'Ticket'. Note that TLS 1.3 servers always use session tickets.+ -- ^ Used on TLS 1.2 servers to decide to use 'SessionID' or 'Ticket'. Note that 'SessionID' and 'Ticket' are integrated as identity in TLS 1.3. } -- | The session manager to do nothing.
Network/TLS/State.hs view
@@ -25,6 +25,7 @@ setVersion, setVersionIfUnset, getVersion,+ getVersionMaybe, getVersionWithDefault, setSecureRenegotiation, getSecureRenegotiation,@@ -37,6 +38,7 @@ setClientEcPointFormatSuggest, getClientEcPointFormatSuggest, setClientSNI,+ clearClientSNI, getClientSNI, getClientCertificateChain, setClientCertificateChain,@@ -44,10 +46,13 @@ setServerCertificateChain, setSession, getSession,- isSessionResuming, getRole,- setExporterSecret,- getExporterSecret,+ --+ setTLS12SessionResuming,+ getTLS12SessionResuming,+ --+ setTLS13ExporterSecret,+ getTLS13ExporterSecret, setTLS13KeyShare, getTLS13KeyShare, setTLS13PreSharedKey,@@ -56,8 +61,8 @@ getTLS13HRR, setTLS13Cookie, getTLS13Cookie,- setClientSupportsPHA,- getClientSupportsPHA,+ setTLS13ClientSupportsPHA,+ getTLS13ClientSupportsPHA, setTLS12SessionTicket, getTLS12SessionTicket, @@ -68,19 +73,18 @@ import Control.Monad.State.Strict import Crypto.Random-import qualified Data.ByteString as B import Data.X509 (CertificateChain)+ import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct-import Network.TLS.Types (HostName, Role (..), Ticket)+import Network.TLS.Types (HostName, Role (..), Secret, Ticket, WireBytes) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState { stSession :: Session- , stSessionResuming :: Bool , -- RFC 5746, Renegotiation Indication Extension -- RFC 5929, Channel Bindings for TLS, "tls-unique" stSecureRenegotiation :: Bool@@ -89,24 +93,29 @@ , -- RFC 5929, Channel Bindings for TLS, "tls-server-end-point" stServerCertificateChain :: Maybe CertificateChain , stExtensionALPN :: Bool -- RFC 7301- , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString))- , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol- , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString))- , stClientALPNSuggest :: Maybe [B.ByteString]+ , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol+ , stHandshakeRecordCont12+ :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)+ , stHandshakeRecordCont13+ :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)+ , stClientALPNSuggest :: Maybe [ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , stClientSNI :: Maybe HostName , stRandomGen :: StateRNG- , stVersion :: Maybe Version , stClientContext :: Role- , stTLS13KeyShare :: Maybe KeyShare+ , stVersion :: Maybe Version+ , --+ stTLS12SessionResuming :: Bool+ , stTLS12SessionTicket :: Maybe Ticket+ , --+ stTLS13KeyShare :: Maybe KeyShare , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: Bool , stTLS13Cookie :: Maybe Cookie- , stExporterSecret :: Maybe ByteString -- TLS 1.3- , stClientSupportsPHA :: Bool -- Post-Handshake Authentication (TLS 1.3)- , stTLS12SessionTicket :: Maybe Ticket+ , stTLS13ExporterSecret :: Maybe Secret+ , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } newtype TLSSt a = TLSSt {runTLSSt :: ErrT TLSError (State TLSState) a}@@ -124,45 +133,45 @@ newTLSState rng clientContext = TLSState { stSession = Session Nothing- , stSessionResuming = False , stSecureRenegotiation = False , stClientVerifyData = Nothing , stServerVerifyData = Nothing , stServerCertificateChain = Nothing , stExtensionALPN = False- , stHandshakeRecordCont = Nothing- , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = Nothing+ , stHandshakeRecordCont12 = (Nothing, [])+ , stHandshakeRecordCont13 = (Nothing, []) , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing , stRandomGen = rng- , stVersion = Nothing , stClientContext = clientContext+ , stVersion = Nothing+ , stTLS12SessionResuming = False+ , stTLS12SessionTicket = Nothing , stTLS13KeyShare = Nothing , stTLS13PreSharedKey = Nothing , stTLS13HRR = False , stTLS13Cookie = Nothing- , stExporterSecret = Nothing- , stClientSupportsPHA = False- , stTLS12SessionTicket = Nothing+ , stTLS13ExporterSecret = Nothing+ , stTLS13ClientSupportsPHA = False } setVerifyDataForSend :: VerifyData -> TLSSt () setVerifyDataForSend bs = do role <- getRole case role of- ClientRole -> modify (\st -> st{stClientVerifyData = Just bs})- ServerRole -> modify (\st -> st{stServerVerifyData = Just bs})+ ClientRole -> modify' (\st -> st{stClientVerifyData = Just bs})+ ServerRole -> modify' (\st -> st{stServerVerifyData = Just bs}) setVerifyDataForRecv :: VerifyData -> TLSSt () setVerifyDataForRecv bs = do role <- getRole case role of- ClientRole -> modify (\st -> st{stServerVerifyData = Just bs})- ServerRole -> modify (\st -> st{stClientVerifyData = Just bs})+ ClientRole -> modify' (\st -> st{stServerVerifyData = Just bs})+ ServerRole -> modify' (\st -> st{stClientVerifyData = Just bs}) finishedHandshakeTypeMaterial :: HandshakeType -> Bool finishedHandshakeTypeMaterial HandshakeType_ClientHello = True@@ -197,20 +206,23 @@ certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake -setSession :: Session -> Bool -> TLSSt ()-setSession session resuming = modify (\st -> st{stSession = session, stSessionResuming = resuming})+setSession :: Session -> TLSSt ()+setSession session = modify' (\st -> st{stSession = session}) getSession :: TLSSt Session getSession = gets stSession -isSessionResuming :: TLSSt Bool-isSessionResuming = gets stSessionResuming+setTLS12SessionResuming :: Bool -> TLSSt ()+setTLS12SessionResuming b = modify' (\st -> st{stTLS12SessionResuming = b}) +getTLS12SessionResuming :: TLSSt Bool+getTLS12SessionResuming = gets stTLS12SessionResuming+ setVersion :: Version -> TLSSt ()-setVersion ver = modify (\st -> st{stVersion = Just ver})+setVersion ver = modify' (\st -> st{stVersion = Just ver}) setVersionIfUnset :: Version -> TLSSt ()-setVersionIfUnset ver = modify maybeSet+setVersionIfUnset ver = modify' maybeSet where maybeSet st = case stVersion st of Nothing -> st{stVersion = Just ver}@@ -221,83 +233,98 @@ 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 setSecureRenegotiation :: Bool -> TLSSt ()-setSecureRenegotiation b = modify (\st -> st{stSecureRenegotiation = b})+setSecureRenegotiation b = modify' (\st -> st{stSecureRenegotiation = b}) getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionALPN :: Bool -> TLSSt ()-setExtensionALPN b = modify (\st -> st{stExtensionALPN = b})+setExtensionALPN b = modify' (\st -> st{stExtensionALPN = b}) getExtensionALPN :: TLSSt Bool getExtensionALPN = gets stExtensionALPN -setNegotiatedProtocol :: B.ByteString -> TLSSt ()-setNegotiatedProtocol s = modify (\st -> st{stNegotiatedProtocol = Just s})+setNegotiatedProtocol :: ByteString -> TLSSt ()+setNegotiatedProtocol s = modify' (\st -> st{stNegotiatedProtocol = Just s}) -getNegotiatedProtocol :: TLSSt (Maybe B.ByteString)+getNegotiatedProtocol :: TLSSt (Maybe ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol -setClientALPNSuggest :: [B.ByteString] -> TLSSt ()-setClientALPNSuggest ps = modify (\st -> st{stClientALPNSuggest = Just ps})+setClientALPNSuggest :: [ByteString] -> TLSSt ()+setClientALPNSuggest ps = modify' (\st -> st{stClientALPNSuggest = Just ps}) -getClientALPNSuggest :: TLSSt (Maybe [B.ByteString])+getClientALPNSuggest :: TLSSt (Maybe [ByteString]) getClientALPNSuggest = gets stClientALPNSuggest setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt ()-setClientEcPointFormatSuggest epf = modify (\st -> st{stClientEcPointFormatSuggest = Just epf})+setClientEcPointFormatSuggest epf = modify' (\st -> st{stClientEcPointFormatSuggest = Just epf}) getClientEcPointFormatSuggest :: TLSSt (Maybe [EcPointFormat]) getClientEcPointFormatSuggest = gets stClientEcPointFormatSuggest setClientCertificateChain :: CertificateChain -> TLSSt ()-setClientCertificateChain s = modify (\st -> st{stClientCertificateChain = Just s})+setClientCertificateChain s = modify' (\st -> st{stClientCertificateChain = Just s}) getClientCertificateChain :: TLSSt (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain setServerCertificateChain :: CertificateChain -> TLSSt ()-setServerCertificateChain s = modify (\st -> st{stServerCertificateChain = Just s})+setServerCertificateChain s = modify' (\st -> st{stServerCertificateChain = Just s}) getServerCertificateChain :: TLSSt (Maybe CertificateChain) getServerCertificateChain = gets stServerCertificateChain setClientSNI :: HostName -> TLSSt ()-setClientSNI hn = modify (\st -> st{stClientSNI = Just hn})+setClientSNI hn = modify' (\st -> st{stClientSNI = Just hn}) +clearClientSNI :: TLSSt ()+clearClientSNI = modify' (\st -> st{stClientSNI = Nothing})+ getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI -getVerifyData :: Role -> TLSSt ByteString+getVerifyData :: Role -> TLSSt VerifyData getVerifyData client = do mVerifyData <- gets (if client == ClientRole then stClientVerifyData else stServerVerifyData)- return $ fromMaybe "" mVerifyData+ return $ fromMaybe (VerifyData "") mVerifyData -getMyVerifyData :: TLSSt (Maybe ByteString)+getMyVerifyData :: TLSSt (Maybe VerifyData) getMyVerifyData = do role <- getRole if role == ClientRole then gets stClientVerifyData else gets stServerVerifyData -getPeerVerifyData :: TLSSt (Maybe ByteString)+getPeerVerifyData :: TLSSt (Maybe VerifyData) getPeerVerifyData = do role <- getRole if role == ClientRole then gets stServerVerifyData else gets stClientVerifyData -getFirstVerifyData :: TLSSt (Maybe ByteString)+getFirstVerifyData :: TLSSt (Maybe VerifyData) getFirstVerifyData = do- resuming <- isSessionResuming- if resuming- then gets stServerVerifyData- else gets stClientVerifyData+ ver <- getVersion+ case ver of+ TLS13 -> gets stServerVerifyData+ _ -> do+ resuming <- getTLS12SessionResuming+ if resuming+ then gets stServerVerifyData+ else gets stClientVerifyData getRole :: TLSSt Role getRole = gets stClientContext@@ -313,44 +340,44 @@ put (st{stRandomGen = rng'}) return a -setExporterSecret :: ByteString -> TLSSt ()-setExporterSecret key = modify (\st -> st{stExporterSecret = Just key})+setTLS12SessionTicket :: Ticket -> TLSSt ()+setTLS12SessionTicket t = modify' (\st -> st{stTLS12SessionTicket = Just t}) -getExporterSecret :: TLSSt (Maybe ByteString)-getExporterSecret = gets stExporterSecret+getTLS12SessionTicket :: TLSSt (Maybe Ticket)+getTLS12SessionTicket = gets stTLS12SessionTicket +setTLS13ExporterSecret :: Secret -> TLSSt ()+setTLS13ExporterSecret key = modify' (\st -> st{stTLS13ExporterSecret = Just key})++getTLS13ExporterSecret :: TLSSt (Maybe Secret)+getTLS13ExporterSecret = gets stTLS13ExporterSecret+ setTLS13KeyShare :: Maybe KeyShare -> TLSSt ()-setTLS13KeyShare mks = modify (\st -> st{stTLS13KeyShare = mks})+setTLS13KeyShare mks = modify' (\st -> st{stTLS13KeyShare = mks}) getTLS13KeyShare :: TLSSt (Maybe KeyShare) getTLS13KeyShare = gets stTLS13KeyShare setTLS13PreSharedKey :: Maybe PreSharedKey -> TLSSt ()-setTLS13PreSharedKey mpsk = modify (\st -> st{stTLS13PreSharedKey = mpsk})+setTLS13PreSharedKey mpsk = modify' (\st -> st{stTLS13PreSharedKey = mpsk}) getTLS13PreSharedKey :: TLSSt (Maybe PreSharedKey) getTLS13PreSharedKey = gets stTLS13PreSharedKey setTLS13HRR :: Bool -> TLSSt ()-setTLS13HRR b = modify (\st -> st{stTLS13HRR = b})+setTLS13HRR b = modify' (\st -> st{stTLS13HRR = b}) getTLS13HRR :: TLSSt Bool getTLS13HRR = gets stTLS13HRR setTLS13Cookie :: Maybe Cookie -> TLSSt ()-setTLS13Cookie mcookie = modify (\st -> st{stTLS13Cookie = mcookie})+setTLS13Cookie mcookie = modify' (\st -> st{stTLS13Cookie = mcookie}) getTLS13Cookie :: TLSSt (Maybe Cookie) getTLS13Cookie = gets stTLS13Cookie -setClientSupportsPHA :: Bool -> TLSSt ()-setClientSupportsPHA b = modify (\st -> st{stClientSupportsPHA = b})--getClientSupportsPHA :: TLSSt Bool-getClientSupportsPHA = gets stClientSupportsPHA--setTLS12SessionTicket :: Ticket -> TLSSt ()-setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t})+setTLS13ClientSupportsPHA :: Bool -> TLSSt ()+setTLS13ClientSupportsPHA b = modify' (\st -> st{stTLS13ClientSupportsPHA = b}) -getTLS12SessionTicket :: TLSSt (Maybe Ticket)-getTLS12SessionTicket = gets stTLS12SessionTicket+getTLS13ClientSupportsPHA :: TLSSt Bool+getTLS13ClientSupportsPHA = gets stTLS13ClientSupportsPHA
Network/TLS/Struct.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} @@ -7,47 +7,6 @@ module Network.TLS.Struct ( Version (..), CipherData (..),- ExtensionID (- ..,- EID_ServerName,- EID_MaxFragmentLength,- EID_ClientCertificateUrl,- EID_TrustedCAKeys,- EID_TruncatedHMAC,- EID_StatusRequest,- EID_UserMapping,- EID_ClientAuthz,- EID_ServerAuthz,- EID_CertType,- EID_SupportedGroups,- EID_EcPointFormats,- EID_SRP,- EID_SignatureAlgorithms,- EID_SRTP,- EID_Heartbeat,- EID_ApplicationLayerProtocolNegotiation,- EID_StatusRequestv2,- EID_SignedCertificateTimestamp,- EID_ClientCertificateType,- EID_ServerCertificateType,- EID_Padding,- EID_EncryptThenMAC,- EID_ExtendedMainSecret,- EID_SessionTicket,- EID_PreSharedKey,- EID_EarlyData,- EID_SupportedVersions,- EID_Cookie,- EID_PskKeyExchangeModes,- EID_CertificateAuthorities,- EID_OidFilters,- EID_PostHandshakeAuth,- EID_SignatureAlgorithmsCert,- EID_KeyShare,- EID_QuicTransportParameters,- EID_SecureRenegotiation- ),- ExtensionRaw (..), CertificateType ( CertificateType, CertificateType_RSA_Sign,@@ -58,34 +17,6 @@ ), fromCertificateType, lastSupportedCertificateType,- HashAlgorithm (- ..,- HashNone,- HashMD5,- HashSHA1,- HashSHA224,- HashSHA256,- HashSHA384,- HashSHA512,- HashIntrinsic- ),- SignatureAlgorithm (- ..,- SignatureAnonymous,- SignatureRSA,- SignatureDSA,- SignatureECDSA,- SignatureRSApssRSAeSHA256,- SignatureRSApssRSAeSHA384,- SignatureRSApssRSAeSHA512,- SignatureEd25519,- SignatureEd448,- SignatureRSApsspssSHA256,- SignatureRSApsspssSHA384,- SignatureRSApsspssSHA512- ),- HashAndSignatureAlgorithm,- supportedSignatureSchemes, DigitallySigned (..), Signature, ProtocolType (@@ -98,9 +29,6 @@ TLSError (..), TLSException (..), DistinguishedName,- BigNum (..),- bigNumToInteger,- bigNumFromInteger, ServerDHParams (..), serverDHParamsToParams, serverDHParamsToPublic,@@ -114,7 +42,7 @@ ServerRandom (..), ClientRandom (..), FinishedData,- VerifyData,+ VerifyData (..), SessionID, Session (..), SessionData (..),@@ -174,23 +102,41 @@ HandshakeType_CertVerify, HandshakeType_ClientKeyXchg, HandshakeType_Finished,- HandshakeType_KeyUpdate+ HandshakeType_KeyUpdate,+ HandshakeType_CompressedCertificate ),+ CertificateChain_ (..),+ emptyCertificateChain_, Handshake (..),- CH (..), packetType, typeOfHandshake,+ module Network.TLS.HashAndSignature,+ ExtensionRaw (..),+ ExtensionID (..),+ showCertificateChain,+ isHelloRetryRequest,+ hrrRandom,+ ClientHello (..),+ ServerHello (..),+ HandshakeR, ) where -import Control.Exception (Exception (..))-import qualified Data.ByteString.Base16 as B16-import qualified Data.ByteString.Char8 as C8-import Data.Typeable-import Data.X509 (CertificateChain, DistinguishedName)+import Data.X509 (+ CertificateChain (..),+ DistinguishedName,+ certSubjectDN,+ getCharacterStringRawData,+ getDistinguishedElements,+ getSigned,+ signedObject,+ )+ import Network.TLS.Crypto+import Network.TLS.Error+import {-# SOURCE #-} Network.TLS.Extension+import Network.TLS.HashAndSignature import Network.TLS.Imports import Network.TLS.Types-import Network.TLS.Util.Serialization ---------------------------------------------------------------- @@ -233,11 +179,11 @@ pattern CertificateType_Ed448_Sign = CertificateType 255 -- fixme: dummy value instance Show CertificateType where- show CertificateType_RSA_Sign = "CertificateType_RSA_Sign"- show CertificateType_DSA_Sign = "CertificateType_DSA_Sign"- show CertificateType_ECDSA_Sign = "CertificateType_ECDSA_Sign"- show CertificateType_Ed25519_Sign = "CertificateType_Ed25519_Sign"- show CertificateType_Ed448_Sign = "CertificateType_Ed448_Sign"+ show CertificateType_RSA_Sign = "rsa_sign"+ show CertificateType_DSA_Sign = "dss_sign"+ show CertificateType_ECDSA_Sign = "ecdsa_sign"+ show CertificateType_Ed25519_Sign = "ed25519_sign"+ show CertificateType_Ed448_Sign = "ed448_sign" show (CertificateType x) = "CertificateType " ++ show x {- FOURMOLU_ENABLE -} @@ -250,122 +196,14 @@ ------------------------------------------------------------ -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 = "HashNone"- show HashMD5 = "HashMD5"- show HashSHA1 = "HashSHA1"- show HashSHA224 = "HashSHA224"- show HashSHA256 = "HashSHA256"- show HashSHA384 = "HashSHA384"- show HashSHA512 = "HashSHA512"- show HashIntrinsic = "HashIntrinsic"- show (HashAlgorithm x) = "HashAlgorithm " ++ 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--instance Show SignatureAlgorithm where- show SignatureAnonymous = "SignatureAnonymous"- show SignatureRSA = "SignatureRSA"- show SignatureDSA = "SignatureDSA"- show SignatureECDSA = "SignatureECDSA"- show SignatureRSApssRSAeSHA256 = "SignatureRSApssRSAeSHA256"- show SignatureRSApssRSAeSHA384 = "SignatureRSApssRSAeSHA384"- show SignatureRSApssRSAeSHA512 = "SignatureRSApssRSAeSHA512"- show SignatureEd25519 = "SignatureEd25519"- show SignatureEd448 = "SignatureEd448"- show SignatureRSApsspssSHA256 = "SignatureRSApsspssSHA256"- show SignatureRSApsspssSHA384 = "SignatureRSApsspssSHA384"- show SignatureRSApsspssSHA512 = "SignatureRSApsspssSHA512"- show (SignatureAlgorithm x) = "SignatureAlgorithm " ++ 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- , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)- , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503)- , (HashSHA512, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)- -- RSASSA-PSS algorithms with public key OID RSASSA-PSS- , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_pss_sha512(0x080b)- , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_pss_sha384(0x080a)- , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- 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)- ]-{- FOURMOLU_ENABLE -}--------------------------------------------------------------- type Signature = ByteString data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature- deriving (Show, Eq)+ deriving (Eq) +instance Show DigitallySigned where+ show (DigitallySigned hs _sig) = "DigitallySigned " ++ show hs ++ " \"...\""+ ---------------------------------------------------------------- newtype ProtocolType = ProtocolType {fromProtocolType :: Word8} deriving (Eq)@@ -393,347 +231,53 @@ ---------------------------------------------------------------- --- | TLSError that might be returned through the TLS stack.------ Prior to version 1.8.0, this type had an @Exception@ instance.--- In version 1.8.0, this instance was removed, and functions in--- this library now only throw 'TLSException'.-data TLSError- = -- | mainly for instance of Error- Error_Misc String- | -- | A fatal error condition was encountered at a low level. The- -- elements of the tuple give (freeform text description, structured- -- error description).- Error_Protocol String AlertDescription- | -- | A non-fatal error condition was encountered at a low level at a low- -- level. The elements of the tuple give (freeform text description,- -- structured error description).- Error_Protocol_Warning String AlertDescription- | Error_Certificate String- | -- | handshake policy failed.- Error_HandshakePolicy String- | Error_EOF- | Error_Packet String- | Error_Packet_unexpected String String- | Error_Packet_Parsing String- deriving (Eq, Show, Typeable)---------------------------------------------------------------------- | TLS Exceptions. Some of the data constructors indicate incorrect use of--- the library, and the documentation for those data constructors calls--- this out. The others wrap 'TLSError' with some kind of context to explain--- when the exception occurred.-data TLSException- = -- | Early termination exception with the reason and the error associated- Terminated Bool String TLSError- | -- | Handshake failed for the reason attached.- HandshakeFailed TLSError- | -- | Failure occurred while sending or receiving data after the- -- TLS handshake succeeded.- PostHandshake TLSError- | -- | Lifts a 'TLSError' into 'TLSException' without provided any context- -- around when the error happened.- Uncontextualized TLSError- | -- | Usage error when the connection has not been established- -- and the user is trying to send or receive data.- -- Indicates that this library has been used incorrectly.- ConnectionNotEstablished- | -- | Expected that a TLS handshake had already taken place, but no TLS- -- handshake had occurred.- -- Indicates that this library has been used incorrectly.- MissingHandshake- deriving (Show, Eq, Typeable)--instance Exception TLSException------------------------------------------------------------------- data Packet- = Handshake [Handshake]+ = Handshake [Handshake] [WireBytes] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Eq) instance Show Packet where- show (Handshake hs) = "Handshake " ++ show hs+ show (Handshake hs _) = "Handshake " ++ show hs show (Alert as) = "Alert " ++ show as show ChangeCipherSpec = "ChangeCipherSpec"- show (AppData bs) = "AppData " ++ C8.unpack (B16.encode bs)+ show (AppData bs) = "AppData " ++ showBytesHex bs data Header = Header ProtocolType Version Word16 deriving (Show, Eq) newtype ServerRandom = ServerRandom {unServerRandom :: ByteString}- deriving (Show, Eq)-newtype ClientRandom = ClientRandom {unClientRandom :: ByteString}- deriving (Show, Eq)-newtype Session = Session (Maybe SessionID) deriving (Show, Eq)--{-# DEPRECATED FinishedData "use VerifyData" #-}-type FinishedData = ByteString-type VerifyData = ByteString---------------------------------------------------------------------- | Identifier of a TLS extension.--- <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt>-newtype ExtensionID = ExtensionID {fromExtensionID :: Word16} deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern EID_ServerName :: ExtensionID -- RFC6066-pattern EID_ServerName = ExtensionID 0x0-pattern EID_MaxFragmentLength :: ExtensionID -- RFC6066-pattern EID_MaxFragmentLength = ExtensionID 0x1-pattern EID_ClientCertificateUrl :: ExtensionID -- RFC6066-pattern EID_ClientCertificateUrl = ExtensionID 0x2-pattern EID_TrustedCAKeys :: ExtensionID -- RFC6066-pattern EID_TrustedCAKeys = ExtensionID 0x3-pattern EID_TruncatedHMAC :: ExtensionID -- RFC6066-pattern EID_TruncatedHMAC = ExtensionID 0x4-pattern EID_StatusRequest :: ExtensionID -- RFC6066-pattern EID_StatusRequest = ExtensionID 0x5-pattern EID_UserMapping :: ExtensionID -- RFC4681-pattern EID_UserMapping = ExtensionID 0x6-pattern EID_ClientAuthz :: ExtensionID -- RFC5878-pattern EID_ClientAuthz = ExtensionID 0x7-pattern EID_ServerAuthz :: ExtensionID -- RFC5878-pattern EID_ServerAuthz = ExtensionID 0x8-pattern EID_CertType :: ExtensionID -- RFC6091-pattern EID_CertType = ExtensionID 0x9-pattern EID_SupportedGroups :: ExtensionID -- RFC8422,8446-pattern EID_SupportedGroups = ExtensionID 0xa-pattern EID_EcPointFormats :: ExtensionID -- RFC4492-pattern EID_EcPointFormats = ExtensionID 0xb-pattern EID_SRP :: ExtensionID -- RFC5054-pattern EID_SRP = ExtensionID 0xc-pattern EID_SignatureAlgorithms :: ExtensionID -- RFC5246,8446-pattern EID_SignatureAlgorithms = ExtensionID 0xd-pattern EID_SRTP :: ExtensionID -- RFC5764-pattern EID_SRTP = ExtensionID 0xe-pattern EID_Heartbeat :: ExtensionID -- RFC6520-pattern EID_Heartbeat = ExtensionID 0xf-pattern EID_ApplicationLayerProtocolNegotiation :: ExtensionID -- RFC7301-pattern EID_ApplicationLayerProtocolNegotiation = ExtensionID 0x10-pattern EID_StatusRequestv2 :: ExtensionID -- RFC6961-pattern EID_StatusRequestv2 = ExtensionID 0x11-pattern EID_SignedCertificateTimestamp :: ExtensionID -- RFC6962-pattern EID_SignedCertificateTimestamp = ExtensionID 0x12-pattern EID_ClientCertificateType :: ExtensionID -- RFC7250-pattern EID_ClientCertificateType = ExtensionID 0x13-pattern EID_ServerCertificateType :: ExtensionID -- RFC7250-pattern EID_ServerCertificateType = ExtensionID 0x14-pattern EID_Padding :: ExtensionID -- RFC5246-pattern EID_Padding = ExtensionID 0x15-pattern EID_EncryptThenMAC :: ExtensionID -- RFC7366-pattern EID_EncryptThenMAC = ExtensionID 0x16-pattern EID_ExtendedMainSecret :: ExtensionID -- REF7627-pattern EID_ExtendedMainSecret = ExtensionID 0x17-pattern EID_SessionTicket :: ExtensionID -- RFC4507-pattern EID_SessionTicket = ExtensionID 0x23-pattern EID_PreSharedKey :: ExtensionID -- RFC8446-pattern EID_PreSharedKey = ExtensionID 0x29-pattern EID_EarlyData :: ExtensionID -- RFC8446-pattern EID_EarlyData = ExtensionID 0x2a-pattern EID_SupportedVersions :: ExtensionID -- RFC8446-pattern EID_SupportedVersions = ExtensionID 0x2b-pattern EID_Cookie :: ExtensionID -- RFC8446-pattern EID_Cookie = ExtensionID 0x2c-pattern EID_PskKeyExchangeModes :: ExtensionID -- RFC8446-pattern EID_PskKeyExchangeModes = ExtensionID 0x2d-pattern EID_CertificateAuthorities :: ExtensionID -- RFC8446-pattern EID_CertificateAuthorities = ExtensionID 0x2f-pattern EID_OidFilters :: ExtensionID -- RFC8446-pattern EID_OidFilters = ExtensionID 0x30-pattern EID_PostHandshakeAuth :: ExtensionID -- RFC8446-pattern EID_PostHandshakeAuth = ExtensionID 0x31-pattern EID_SignatureAlgorithmsCert :: ExtensionID -- RFC8446-pattern EID_SignatureAlgorithmsCert = ExtensionID 0x32-pattern EID_KeyShare :: ExtensionID -- RFC8446-pattern EID_KeyShare = ExtensionID 0x33-pattern EID_QuicTransportParameters :: ExtensionID -- RFC9001-pattern EID_QuicTransportParameters = ExtensionID 0x39-pattern EID_SecureRenegotiation :: ExtensionID -- RFC5746-pattern EID_SecureRenegotiation = ExtensionID 0xff01--instance Show ExtensionID where- show EID_ServerName = "ServerName"- show EID_MaxFragmentLength = "MaxFragmentLength"- show EID_ClientCertificateUrl = "ClientCertificateUrl"- show EID_TrustedCAKeys = "TrustedCAKeys"- show EID_TruncatedHMAC = "TruncatedHMAC"- show EID_StatusRequest = "StatusRequest"- show EID_UserMapping = "UserMapping"- show EID_ClientAuthz = "ClientAuthz"- show EID_ServerAuthz = "ServerAuthz"- show EID_CertType = "CertType"- show EID_SupportedGroups = "SupportedGroups"- show EID_EcPointFormats = "EcPointFormats"- show EID_SRP = "SRP"- show EID_SignatureAlgorithms = "SignatureAlgorithms"- show EID_SRTP = "SRTP"- show EID_Heartbeat = "Heartbeat"- show EID_ApplicationLayerProtocolNegotiation = "ApplicationLayerProtocolNegotiation"- show EID_StatusRequestv2 = "StatusRequestv2"- show EID_SignedCertificateTimestamp = "SignedCertificateTimestamp"- show EID_ClientCertificateType = "ClientCertificateType"- show EID_ServerCertificateType = "ServerCertificateType"- show EID_Padding = "Padding"- show EID_EncryptThenMAC = "EncryptThenMAC"- show EID_ExtendedMainSecret = "ExtendedMainSecret"- show EID_SessionTicket = "SessionTicket"- show EID_PreSharedKey = "PreSharedKey"- show EID_EarlyData = "EarlyData"- show EID_SupportedVersions = "SupportedVersions"- show EID_Cookie = "Cookie"- show EID_PskKeyExchangeModes = "PskKeyExchangeModes"- show EID_CertificateAuthorities = "CertificateAuthorities"- show EID_OidFilters = "OidFilters"- show EID_PostHandshakeAuth = "PostHandshakeAuth"- show EID_SignatureAlgorithmsCert = "SignatureAlgorithmsCert"- show EID_KeyShare = "KeyShare"- show EID_QuicTransportParameters = "QuicTransportParameters"- show EID_SecureRenegotiation = "SecureRenegotiation"- show (ExtensionID x) = "ExtensionID " ++ show x-{- FOURMOLU_ENABLE -}---------------------------------------------------------------------- | The raw content of a TLS extension.-data ExtensionRaw = ExtensionRaw ExtensionID ByteString deriving (Eq)--instance Show ExtensionRaw where- show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs------------------------------------------------------------------+instance Show ServerRandom where+ show sr@(ServerRandom bs)+ | isHelloRetryRequest sr = "HelloRetryReqest"+ | otherwise = "ServerRandom " ++ showBytesHex bs -newtype AlertLevel = AlertLevel {fromAlertLevel :: Word8} deriving (Eq)+hrrRandom :: ServerRandom+hrrRandom =+ ServerRandom+ "\xCF\x21\xAD\x74\xE5\x9A\x61\x11\xBE\x1D\x8C\x02\x1E\x65\xB8\x91\xC2\xA2\x11\x16\x7A\xBB\x8C\x5E\x07\x9E\x09\xE2\xC8\xA8\x33\x9C" -{- FOURMOLU_DISABLE -}-pattern AlertLevel_Warning :: AlertLevel-pattern AlertLevel_Warning = AlertLevel 1-pattern AlertLevel_Fatal :: AlertLevel-pattern AlertLevel_Fatal = AlertLevel 2+isHelloRetryRequest :: ServerRandom -> Bool+isHelloRetryRequest = (== hrrRandom) -instance Show AlertLevel where- show AlertLevel_Warning = "AlertLevel_Warning"- show AlertLevel_Fatal = "AlertLevel_Fatal"- show (AlertLevel x) = "AlertLevel " ++ show x-{- FOURMOLU_ENABLE -}+newtype ClientRandom = ClientRandom {unClientRandom :: ByteString}+ deriving (Eq) -----------------------------------------------------------------+instance Show ClientRandom where+ show (ClientRandom bs) = "ClientRandom " ++ showBytesHex bs -newtype AlertDescription = AlertDescription {fromAlertDescription :: Word8}- deriving (Eq)+newtype Session = Session (Maybe SessionID) deriving (Eq)+instance Show Session where+ show (Session Nothing) = "Session \"\""+ show (Session (Just bs)) = "Session " ++ showBytesHex bs -{- FOURMOLU_DISABLE -}-pattern CloseNotify :: AlertDescription-pattern CloseNotify = AlertDescription 0-pattern UnexpectedMessage :: AlertDescription-pattern UnexpectedMessage = AlertDescription 10-pattern BadRecordMac :: AlertDescription-pattern BadRecordMac = AlertDescription 20-pattern DecryptionFailed :: AlertDescription-pattern DecryptionFailed = AlertDescription 21-pattern RecordOverflow :: AlertDescription-pattern RecordOverflow = AlertDescription 22-pattern DecompressionFailure :: AlertDescription-pattern DecompressionFailure = AlertDescription 30-pattern HandshakeFailure :: AlertDescription-pattern HandshakeFailure = AlertDescription 40-pattern BadCertificate :: AlertDescription-pattern BadCertificate = AlertDescription 42-pattern UnsupportedCertificate :: AlertDescription-pattern UnsupportedCertificate = AlertDescription 43-pattern CertificateRevoked :: AlertDescription-pattern CertificateRevoked = AlertDescription 44-pattern CertificateExpired :: AlertDescription-pattern CertificateExpired = AlertDescription 45-pattern CertificateUnknown :: AlertDescription-pattern CertificateUnknown = AlertDescription 46-pattern IllegalParameter :: AlertDescription-pattern IllegalParameter = AlertDescription 47-pattern UnknownCa :: AlertDescription-pattern UnknownCa = AlertDescription 48-pattern AccessDenied :: AlertDescription-pattern AccessDenied = AlertDescription 49-pattern DecodeError :: AlertDescription-pattern DecodeError = AlertDescription 50-pattern DecryptError :: AlertDescription-pattern DecryptError = AlertDescription 51-pattern ExportRestriction :: AlertDescription-pattern ExportRestriction = AlertDescription 60-pattern ProtocolVersion :: AlertDescription-pattern ProtocolVersion = AlertDescription 70-pattern InsufficientSecurity :: AlertDescription-pattern InsufficientSecurity = AlertDescription 71-pattern InternalError :: AlertDescription-pattern InternalError = AlertDescription 80-pattern InappropriateFallback :: AlertDescription-pattern InappropriateFallback = AlertDescription 86 -- RFC7507-pattern UserCanceled :: AlertDescription-pattern UserCanceled = AlertDescription 90-pattern NoRenegotiation :: AlertDescription-pattern NoRenegotiation = AlertDescription 100-pattern MissingExtension :: AlertDescription-pattern MissingExtension = AlertDescription 109-pattern UnsupportedExtension :: AlertDescription-pattern UnsupportedExtension = AlertDescription 110-pattern CertificateUnobtainable :: AlertDescription-pattern CertificateUnobtainable = AlertDescription 111-pattern UnrecognizedName :: AlertDescription-pattern UnrecognizedName = AlertDescription 112-pattern BadCertificateStatusResponse :: AlertDescription-pattern BadCertificateStatusResponse = AlertDescription 113-pattern BadCertificateHashValue :: AlertDescription-pattern BadCertificateHashValue = AlertDescription 114-pattern UnknownPskIdentity :: AlertDescription-pattern UnknownPskIdentity = AlertDescription 115-pattern CertificateRequired :: AlertDescription-pattern CertificateRequired = AlertDescription 116-pattern GeneralError :: AlertDescription-pattern GeneralError = AlertDescription 117-pattern NoApplicationProtocol :: AlertDescription-pattern NoApplicationProtocol = AlertDescription 120 -- RFC7301+{-# DEPRECATED FinishedData "use VerifyData" #-}+type FinishedData = ByteString -instance Show AlertDescription where- show CloseNotify = "CloseNotify"- show UnexpectedMessage = "UnexpectedMessage"- show BadRecordMac = "BadRecordMac"- show DecryptionFailed = "DecryptionFailed"- show RecordOverflow = "RecordOverflow"- show DecompressionFailure = "DecompressionFailure"- show HandshakeFailure = "HandshakeFailure"- show BadCertificate = "BadCertificate"- show UnsupportedCertificate = "UnsupportedCertificate"- show CertificateRevoked = "CertificateRevoked"- show CertificateExpired = "CertificateExpired"- show CertificateUnknown = "CertificateUnknown"- show IllegalParameter = "IllegalParameter"- show UnknownCa = "UnknownCa"- show AccessDenied = "AccessDenied"- show DecodeError = "DecodeError"- show DecryptError = "DecryptError"- show ExportRestriction = "ExportRestriction"- show ProtocolVersion = "ProtocolVersion"- show InsufficientSecurity = "InsufficientSecurity"- show InternalError = "InternalError"- show InappropriateFallback = "InappropriateFallback"- show UserCanceled = "UserCanceled"- show NoRenegotiation = "NoRenegotiation"- show MissingExtension = "MissingExtension"- show UnsupportedExtension = "UnsupportedExtension"- show CertificateUnobtainable = "CertificateUnobtainable"- show UnrecognizedName = "UnrecognizedName"- show BadCertificateStatusResponse = "BadCertificateStatusResponse"- show BadCertificateHashValue = "BadCertificateHashValue"- show UnknownPskIdentity = "UnknownPskIdentity"- show CertificateRequired = "CertificateRequired"- show GeneralError = "GeneralError"- show NoApplicationProtocol = "NoApplicationProtocol"- show (AlertDescription x) = "AlertDescription " ++ show x-{- FOURMOLU_ENABLE -}+newtype VerifyData = VerifyData ByteString deriving (Eq)+instance Show VerifyData where+ show (VerifyData bs) = showBytesHex bs ---------------------------------------------------------------- @@ -741,63 +285,58 @@ deriving (Eq) {- FOURMOLU_DISABLE -}-pattern HandshakeType_HelloRequest :: HandshakeType-pattern HandshakeType_HelloRequest = HandshakeType 0-pattern HandshakeType_ClientHello :: HandshakeType-pattern HandshakeType_ClientHello = HandshakeType 1-pattern HandshakeType_ServerHello :: HandshakeType-pattern HandshakeType_ServerHello = HandshakeType 2-pattern HandshakeType_NewSessionTicket :: HandshakeType-pattern HandshakeType_NewSessionTicket = HandshakeType 4-pattern HandshakeType_EndOfEarlyData :: HandshakeType-pattern HandshakeType_EndOfEarlyData = HandshakeType 5-pattern HandshakeType_EncryptedExtensions :: HandshakeType-pattern HandshakeType_EncryptedExtensions = HandshakeType 8-pattern HandshakeType_Certificate :: HandshakeType-pattern HandshakeType_Certificate = HandshakeType 11-pattern HandshakeType_ServerKeyXchg :: HandshakeType-pattern HandshakeType_ServerKeyXchg = HandshakeType 12-pattern HandshakeType_CertRequest :: HandshakeType-pattern HandshakeType_CertRequest = HandshakeType 13-pattern HandshakeType_ServerHelloDone :: HandshakeType-pattern HandshakeType_ServerHelloDone = HandshakeType 14-pattern HandshakeType_CertVerify :: HandshakeType-pattern HandshakeType_CertVerify = HandshakeType 15-pattern HandshakeType_ClientKeyXchg :: HandshakeType-pattern HandshakeType_ClientKeyXchg = HandshakeType 16-pattern HandshakeType_Finished :: HandshakeType-pattern HandshakeType_Finished = HandshakeType 20-pattern HandshakeType_KeyUpdate :: HandshakeType-pattern HandshakeType_KeyUpdate = HandshakeType 24+pattern HandshakeType_HelloRequest :: HandshakeType+pattern HandshakeType_HelloRequest = HandshakeType 0+pattern HandshakeType_ClientHello :: HandshakeType+pattern HandshakeType_ClientHello = HandshakeType 1+pattern HandshakeType_ServerHello :: HandshakeType+pattern HandshakeType_ServerHello = HandshakeType 2+pattern HandshakeType_NewSessionTicket :: HandshakeType+pattern HandshakeType_NewSessionTicket = HandshakeType 4+pattern HandshakeType_EndOfEarlyData :: HandshakeType+pattern HandshakeType_EndOfEarlyData = HandshakeType 5+pattern HandshakeType_EncryptedExtensions :: HandshakeType+pattern HandshakeType_EncryptedExtensions = HandshakeType 8+pattern HandshakeType_Certificate :: HandshakeType+pattern HandshakeType_Certificate = HandshakeType 11+pattern HandshakeType_ServerKeyXchg :: HandshakeType+pattern HandshakeType_ServerKeyXchg = HandshakeType 12+pattern HandshakeType_CertRequest :: HandshakeType+pattern HandshakeType_CertRequest = HandshakeType 13+pattern HandshakeType_ServerHelloDone :: HandshakeType+pattern HandshakeType_ServerHelloDone = HandshakeType 14+pattern HandshakeType_CertVerify :: HandshakeType+pattern HandshakeType_CertVerify = HandshakeType 15+pattern HandshakeType_ClientKeyXchg :: HandshakeType+pattern HandshakeType_ClientKeyXchg = HandshakeType 16+pattern HandshakeType_Finished :: HandshakeType+pattern HandshakeType_Finished = HandshakeType 20+pattern HandshakeType_KeyUpdate :: HandshakeType+pattern HandshakeType_KeyUpdate = HandshakeType 24+pattern HandshakeType_CompressedCertificate :: HandshakeType+pattern HandshakeType_CompressedCertificate = HandshakeType 25 instance Show HandshakeType where- show HandshakeType_HelloRequest = "HandshakeType_HelloRequest"- show HandshakeType_ClientHello = "HandshakeType_ClientHello"- show HandshakeType_ServerHello = "HandshakeType_ServerHello"- show HandshakeType_Certificate = "HandshakeType_Certificate"- show HandshakeType_ServerKeyXchg = "HandshakeType_ServerKeyXchg"- show HandshakeType_CertRequest = "HandshakeType_CertRequest"- show HandshakeType_ServerHelloDone = "HandshakeType_ServerHelloDone"- show HandshakeType_CertVerify = "HandshakeType_CertVerify"- show HandshakeType_ClientKeyXchg = "HandshakeType_ClientKeyXchg"- show HandshakeType_Finished = "HandshakeType_Finished"- show HandshakeType_NewSessionTicket = "HandshakeType_NewSessionTicket"- show (HandshakeType x) = "HandshakeType " ++ show x+ show HandshakeType_HelloRequest = "HelloRequest"+ show HandshakeType_ClientHello = "ClientHello"+ show HandshakeType_ServerHello = "ServerHello"+ show HandshakeType_NewSessionTicket = "NewSessionTicket"+ show HandshakeType_EndOfEarlyData = "EndOfEarlyData"+ show HandshakeType_EncryptedExtensions = "EncryptedExtensions"+ show HandshakeType_Certificate = "Certificate"+ show HandshakeType_ServerKeyXchg = "ServerKeyXchg"+ show HandshakeType_CertRequest = "CertRequest"+ show HandshakeType_ServerHelloDone = "ServerHelloDone"+ show HandshakeType_CertVerify = "CertVerify"+ show HandshakeType_ClientKeyXchg = "ClientKeyXchg"+ show HandshakeType_Finished = "Finished"+ show HandshakeType_KeyUpdate = "KeyUpdate"+ show HandshakeType_CompressedCertificate = "CompressedCertificate"+ show (HandshakeType x) = "HandshakeType " ++ show x {- FOURMOLU_ENABLE -} ---------------------------------------------------------------- -newtype BigNum = BigNum ByteString- deriving (Show, Eq)--bigNumToInteger :: BigNum -> Integer-bigNumToInteger (BigNum b) = os2ip b--bigNumFromInteger :: Integer -> BigNum-bigNumFromInteger i = BigNum $ i2osp i------------------------------------------------------------------- data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum@@ -824,7 +363,7 @@ ---------------------------------------------------------------- -data ServerECDHParams = ServerECDHParams Group GroupPublic+data ServerECDHParams = ServerECDHParams Group GroupPublicA deriving (Show, Eq) ----------------------------------------------------------------@@ -852,39 +391,79 @@ | SKX_DH_RSA (Maybe ServerRSAParams) | SKX_Unparsed ByteString -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. | SKX_Unknown ByteString- deriving (Show, Eq)+ deriving (Eq) +{- FOURMOLU_DISABLE -}+instance Show ServerKeyXchgAlgorithmData where+ show (SKX_DH_Anon _) = "SKX_DH_Anon"+ show (SKX_DHE_DSA _ _) = "SKX_DHE_DSA"+ show (SKX_DHE_RSA _ _) = "SKX_DHE_RSA"+ show (SKX_ECDHE_RSA _ _) = "SKX_ECDHE_RSA"+ show (SKX_ECDHE_ECDSA _ _) = "SKX_ECDHE_ECDSA"+ show (SKX_RSA _) = "SKX_RSA"+ show (SKX_DH_DSA _) = "SKX_DH_DSA"+ show (SKX_DH_RSA _) = "SKX_DH_RSA"+ show (SKX_Unparsed _) = "SKX_Unparsed"+ show (SKX_Unknown _) = "SKX_Unknown"+{- FOURMOLU_ENABLE -}+ ---------------------------------------------------------------- data ClientKeyXchgAlgorithmData = CKX_RSA ByteString | CKX_DH DHPublic | CKX_ECDH ByteString- deriving (Show, Eq)+ deriving (Eq) +instance Show ClientKeyXchgAlgorithmData where+ show (CKX_RSA _bs) = "CKX_RSA \"...\""+ show (CKX_DH pub) = "CKX_DH " ++ show pub+ show (CKX_ECDH _bs) = "CKX_ECDH \"...\""+ ---------------------------------------------------------------- -data CH = CH- { chSession :: Session- , chCiphers :: [CipherID]+newtype CertificateChain_ = CertificateChain_ CertificateChain deriving (Eq)+instance Show CertificateChain_ where+ show (CertificateChain_ cc) = showCertificateChain cc++emptyCertificateChain_ :: CertificateChain_+emptyCertificateChain_ = CertificateChain_ (CertificateChain [])++showCertificateChain :: CertificateChain -> String+showCertificateChain (CertificateChain xs) = show $ map getName xs+ where+ getName =+ maybe "" getCharacterStringRawData+ . lookup [2, 5, 4, 3]+ . getDistinguishedElements+ . certSubjectDN+ . signedObject+ . getSigned++data ClientHello = CH+ { chVersion :: Version+ , chRandom :: ClientRandom+ , chSession :: Session+ , chCiphers :: [CipherId]+ , chComps :: [CompressionID] , chExtensions :: [ExtensionRaw] }- deriving (Show, Eq)+ deriving (Eq, Show) +data ServerHello = SH+ { shVersion :: Version+ , shRandom :: ServerRandom+ , shSession :: Session+ , shCipher :: CipherId+ , shComp :: CompressionID+ , shExtensions :: [ExtensionRaw]+ }+ deriving (Eq, Show)+ data Handshake- = ClientHello- Version- ClientRandom- [CompressionID]- CH- | ServerHello- Version- ServerRandom- Session- CipherID- CompressionID- [ExtensionRaw]- | Certificate CertificateChain+ = ClientHello ClientHello+ | ServerHello ServerHello+ | Certificate CertificateChain_ | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData@@ -900,7 +479,7 @@ {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType-packetType (Handshake _) = ProtocolType_Handshake+packetType (Handshake _ _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData@@ -918,3 +497,5 @@ typeOfHandshake Finished{} = HandshakeType_Finished typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket {- FOURMOLU_ENABLE -}++type HandshakeR = (Handshake, WireBytes)
Network/TLS/Struct13.hs view
@@ -4,15 +4,19 @@ typeOfHandshake13, contentType, KeyUpdate (..),+ CertReqContext,+ isKeyUpdate13,+ TicketNonce (..),+ SessionIDorTicket_ (..),+ Handshake13R, ) where -import Data.X509 (CertificateChain) import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Types data Packet13- = Handshake13 [Handshake13]+ = Handshake13 [Handshake13] [WireBytes] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString@@ -23,32 +27,45 @@ | UpdateRequested deriving (Show, Eq) -type TicketNonce = ByteString+newtype TicketNonce = TicketNonce ByteString deriving (Eq) +instance Show TicketNonce where+ show (TicketNonce bs) = showBytesHex bs++newtype SessionIDorTicket_ = SessionIDorTicket_ ByteString deriving (Eq)++instance Show SessionIDorTicket_ where+ show (SessionIDorTicket_ bs) = showBytesHex bs+ -- fixme: convert Word32 to proper data type data Handshake13- = ServerHello13 ServerRandom Session CipherID [ExtensionRaw]- | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw]+ = ServerHello13 ServerHello+ | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket_ [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw]+ | Certificate13 CertReqContext CertificateChain_ [[ExtensionRaw]] | CertRequest13 CertReqContext [ExtensionRaw]- | Certificate13 CertReqContext CertificateChain [[ExtensionRaw]]- | CertVerify13 HashAndSignatureAlgorithm Signature+ | CertVerify13 DigitallySigned | Finished13 VerifyData | KeyUpdate13 KeyUpdate+ | CompressedCertificate13 CertReqContext CertificateChain_ [[ExtensionRaw]] deriving (Show, Eq) +-- | Certificate request context for TLS 1.3.+type CertReqContext = ByteString+ {- FOURMOLU_DISABLE -} typeOfHandshake13 :: Handshake13 -> HandshakeType-typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello-typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData-typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket-typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions-typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest-typeOfHandshake13 Certificate13{} = HandshakeType_Certificate-typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify-typeOfHandshake13 Finished13{} = HandshakeType_Finished-typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate+typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello+typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket+typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData+typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions+typeOfHandshake13 Certificate13{} = HandshakeType_Certificate+typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest+typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify+typeOfHandshake13 Finished13{} = HandshakeType_Finished+typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate+typeOfHandshake13 CompressedCertificate13{} = HandshakeType_CompressedCertificate contentType :: Packet13 -> ProtocolType contentType ChangeCipherSpec13 = ProtocolType_ChangeCipherSpec@@ -56,3 +73,9 @@ contentType Alert13{} = ProtocolType_Alert contentType AppData13{} = ProtocolType_AppData {- FOURMOLU_ENABLE -}++isKeyUpdate13 :: Handshake13 -> Bool+isKeyUpdate13 (KeyUpdate13 _) = True+isKeyUpdate13 _ = False++type Handshake13R = (Handshake13, WireBytes)
Network/TLS/Types.hs view
@@ -1,186 +1,88 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE PatternSynonyms #-}- module Network.TLS.Types (- Version (Version, SSL2, SSL3, TLS10, TLS11, TLS12, TLS13),- SessionID,- SessionIDorTicket,- Ticket,- isTicket,- toSessionID,- SessionData (..),- SessionFlag (..),- CertReqContext,- TLS13TicketInfo (..),- CipherID,- CompressionID,+ module Network.TLS.Types.Cipher,+ module Network.TLS.Types.Secret,+ module Network.TLS.Types.Session,+ module Network.TLS.Types.Version,+ HostName, Role (..), invertRole, Direction (..),- HostName,- Second,- Millisecond,- EarlySecret,- HandshakeSecret,- ApplicationSecret,- ResumptionSecret,- BaseSecret (..),- AnyTrafficSecret (..),- ClientTrafficSecret (..),- ServerTrafficSecret (..),- TrafficSecrets,- SecretTriple (..),- SecretPair (..),- MainSecret (..),+ BigNum (..),+ bigNumToInteger,+ bigNumFromInteger,+ defaultRecordSizeLimit,+ maxHandshakeSize,+ TranscriptHash (..),+ WireBytes, ) where -import Codec.Serialise-import qualified Data.ByteString as B-import GHC.Generics import Network.Socket (HostName)-import Network.TLS.Crypto (Group, Hash (..), hash)-import Network.TLS.Imports -type Second = Word32-type Millisecond = Word64---- | Versions known to TLS-newtype Version = Version Word16 deriving (Eq, Ord, Generic)-{- FOURMOLU_DISABLE -}-pattern SSL2 :: Version-pattern SSL2 = Version 0x0200-pattern SSL3 :: Version-pattern SSL3 = Version 0x0300-pattern TLS10 :: Version-pattern TLS10 = Version 0x0301-pattern TLS11 :: Version-pattern TLS11 = Version 0x0302-pattern TLS12 :: Version-pattern TLS12 = Version 0x0303-pattern TLS13 :: Version-pattern TLS13 = Version 0x0304--instance Show Version where- show SSL2 = "SSL2"- show SSL3 = "SSL3"- show TLS10 = "TLS1.0"- show TLS11 = "TLS1.1"- show TLS12 = "TLS1.2"- show TLS13 = "TLS1.3"- show (Version x) = "Version " ++ show x-{- FOURMOLU_ENABLE -}---- | A session ID-type SessionID = ByteString---- | Identity-type SessionIDorTicket = ByteString---- | Encrypted session ticket (encrypt(encode 'SessionData')).-type Ticket = ByteString--isTicket :: SessionIDorTicket -> Bool-isTicket x- | B.length x > 32 = True- | otherwise = False--toSessionID :: Ticket -> SessionID-toSessionID = hash SHA256---- | Session data to resume-data SessionData = SessionData- { sessionVersion :: Version- , sessionCipher :: CipherID- , sessionCompression :: CompressionID- , sessionClientSNI :: Maybe HostName- , sessionSecret :: ByteString- , sessionGroup :: Maybe Group- , sessionTicketInfo :: Maybe TLS13TicketInfo- , sessionALPN :: Maybe ByteString- , sessionMaxEarlyDataSize :: Int- , sessionFlags :: [SessionFlag]- } -- sessionFromTicket :: Bool- deriving (Show, Eq, Generic)---- | Some session flags-data SessionFlag- = -- | Session created with Extended Main Secret- SessionEMS- deriving (Show, Eq, Enum, Generic)---- | Certificate request context for TLS 1.3.-type CertReqContext = ByteString--data TLS13TicketInfo = TLS13TicketInfo- { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds- , ageAdd :: Second -- NewSessionTicket.ticket_age_add- , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime- , estimatedRTT :: Maybe Millisecond- }- deriving (Show, Eq, Generic)---- | Cipher identification-type CipherID = Word16+import Network.TLS.Imports+import Network.TLS.Types.Cipher+import Network.TLS.Types.Secret+import Network.TLS.Types.Session+import Network.TLS.Types.Version+import Network.TLS.Util.Serialization --- | Compression identification-type CompressionID = Word8+---------------------------------------------------------------- -- | Role data Role = ClientRole | ServerRole deriving (Show, Eq) --- | Direction-data Direction = Tx | Rx- deriving (Show, Eq)- invertRole :: Role -> Role invertRole ClientRole = ServerRole invertRole ServerRole = ClientRole --- | Phantom type indicating early traffic secret.-data EarlySecret+---------------------------------------------------------------- --- | Phantom type indicating handshake traffic secrets.-data HandshakeSecret+-- | Direction+data Direction = Tx | Rx+ deriving (Show, Eq) --- | Phantom type indicating application traffic secrets.-data ApplicationSecret+---------------------------------------------------------------- -data ResumptionSecret+newtype BigNum = BigNum ByteString+ deriving (Show, Eq) -newtype BaseSecret a = BaseSecret ByteString deriving (Show)-newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show)+bigNumToInteger :: BigNum -> Integer+bigNumToInteger (BigNum b) = os2ip b --- | A client traffic secret, typed with a parameter indicating a step in the--- TLS key schedule.-newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show)+bigNumFromInteger :: Integer -> BigNum+bigNumFromInteger i = BigNum $ i2osp i --- | A server traffic secret, typed with a parameter indicating a step in the--- TLS key schedule.-newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving (Show)+---------------------------------------------------------------- -data SecretTriple a = SecretTriple- { triBase :: BaseSecret a- , triClient :: ClientTrafficSecret a- , triServer :: ServerTrafficSecret a- }- deriving (Show)+-- For plaintext+-- 2^14 for TLS 1.2+-- 2^14 + 1 for TLS 1.3+defaultRecordSizeLimit :: Int+defaultRecordSizeLimit = 16384 -data SecretPair a = SecretPair- { pairBase :: BaseSecret a- , pairClient :: ClientTrafficSecret a- }+---------------------------------------------------------------- --- | Hold both client and server traffic secrets at the same step.-type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a)+-- | 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 --- Main secret for TLS 1.2 or earlier.-newtype MainSecret = MainSecret ByteString deriving (Show)+---------------------------------------------------------------- +newtype TranscriptHash = TranscriptHash ByteString++instance Show TranscriptHash where+ show (TranscriptHash bs) = showBytesHex bs+ ---------------------------------------------------------------- -instance Serialise Version-instance Serialise TLS13TicketInfo-instance Serialise SessionFlag-instance Serialise SessionData+type WireBytes = [ByteString]
+ Network/TLS/Types/Cipher.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.TLS.Types.Cipher where++import Crypto.Cipher.Types (AuthTag)+import Data.ByteArray (ScrubbedBytes)+import Data.IORef+import GHC.Generics+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf++import Network.TLS.Crypto (Hash (..))+import Network.TLS.Imports+import Network.TLS.Types.Version++----------------------------------------------------------------++type PlainText = ByteString+type CipherText = ByteString+type Secret = ScrubbedBytes+type Key = ScrubbedBytes+type IV = ByteString+type Nonce = ByteString -- aka IV+type AddDat = ByteString++----------------------------------------------------------------++-- | Cipher identification+type CipherID = Word16++newtype CipherId = CipherId {fromCipherId :: Word16}+ deriving (Eq, Ord, Enum, Num, Integral, Real, Read, Generic)++instance Show CipherId where+ show (CipherId 0x00FF) = "TLS_EMPTY_RENEGOTIATION_INFO_SCSV"+ show (CipherId n) = case find eqID dict of+ Just c -> cipherName c+ Nothing -> printf "0x%04X" n+ where+ eqID c = cipherID c == n+ dict = unsafePerformIO $ readIORef globalCipherDict++-- "ciphersuite" is designed extensible.+-- So, it's not available from internal modules.+-- This is a compromise to gule "ciphersuite" to Show CipherID.++{-# NOINLINE globalCipherDict #-}+globalCipherDict :: IORef [Cipher]+globalCipherDict = unsafePerformIO $ newIORef []++----------------------------------------------------------------++-- | Cipher algorithm+data Cipher = Cipher+ { cipherID :: CipherID+ , cipherName :: String+ , cipherHash :: Hash+ , cipherBulk :: Bulk+ , cipherKeyExchange :: CipherKeyExchangeType+ , cipherMinVer :: Maybe Version+ , cipherPRFHash :: Maybe Hash+ }++instance Show Cipher where+ show c = cipherName c++instance Eq Cipher where+ (==) c1 c2 = cipherID c1 == cipherID c2++----------------------------------------------------------------++data CipherKeyExchangeType+ = CipherKeyExchange_RSA+ | CipherKeyExchange_DH_Anon+ | CipherKeyExchange_DHE_RSA+ | CipherKeyExchange_ECDHE_RSA+ | CipherKeyExchange_DHE_DSA+ | CipherKeyExchange_DH_DSA+ | CipherKeyExchange_DH_RSA+ | CipherKeyExchange_ECDH_ECDSA+ | CipherKeyExchange_ECDH_RSA+ | CipherKeyExchange_ECDHE_ECDSA+ | CipherKeyExchange_TLS13 -- not expressed in cipher suite+ deriving (Show, Eq)++----------------------------------------------------------------++data Bulk = Bulk+ { bulkName :: String+ , bulkKeySize :: Int+ , bulkIVSize :: Int+ , bulkExplicitIV :: Int -- Explicit size for IV for AEAD Cipher, 0 otherwise+ , bulkAuthTagLen :: Int -- Authentication tag length in bytes for AEAD Cipher, 0 otherwise+ , bulkBlockSize :: Int+ , bulkF :: BulkFunctions+ }++instance Show Bulk where+ show bulk = bulkName bulk+instance Eq Bulk where+ b1 == b2 =+ and+ [ bulkName b1 == bulkName b2+ , bulkKeySize b1 == bulkKeySize b2+ , bulkIVSize b1 == bulkIVSize b2+ , bulkBlockSize b1 == bulkBlockSize b2+ ]++----------------------------------------------------------------++data BulkFunctions+ = BulkBlockF (BulkDirection -> BulkKey -> BulkBlock)+ | BulkStreamF (BulkDirection -> BulkKey -> BulkStream)+ | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD)++data BulkDirection = BulkEncrypt | BulkDecrypt+ deriving (Show, Eq)++type BulkKey = Secret+type BulkIV = Nonce+type BulkNonce = Nonce+type BulkAdditionalData = ByteString++type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV)++newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream))++type BulkAEAD =+ BulkNonce -> ByteString -> BulkAdditionalData -> (ByteString, AuthTag)
+ Network/TLS/Types/Secret.hs view
@@ -0,0 +1,86 @@+-- | 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++-- | Phantom type indicating early traffic secret.+data EarlySecret++-- | Phantom type indicating handshake traffic secrets.+data HandshakeSecret++-- | Phantom type indicating application traffic secrets.+data ApplicationSecret++data ResumptionSecret++newtype BaseSecret a = BaseSecret Secret++instance Show (BaseSecret a) where+ show _ = "<secret>"++instance DebugShow (BaseSecret a) where+ debugShow (BaseSecret bs) = showBytesHex $ convert bs++newtype AnyTrafficSecret a = AnyTrafficSecret Secret++instance Show (AnyTrafficSecret a) where+ 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 _ = "<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 _ = "<secret>"++instance DebugShow (ServerTrafficSecret a) where+ debugShow (ServerTrafficSecret bs) = showBytesHex $ convert bs++data SecretTriple a = SecretTriple+ { triBase :: BaseSecret a+ , triClient :: ClientTrafficSecret a+ , triServer :: ServerTrafficSecret a+ }+ deriving (Show)++data SecretPair a = SecretPair+ { pairBase :: BaseSecret a+ , pairClient :: ClientTrafficSecret a+ }+ deriving (Show)++-- | Hold both client and server traffic secrets at the same step.+type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a)++-- Main secret for TLS 1.2 or earlier.+newtype MainSecret = MainSecret Secret++instance Show MainSecret where+ show _ = "<secret>"++instance DebugShow MainSecret where+ debugShow (MainSecret bs) = showBytesHex $ convert bs
+ Network/TLS/Types/Session.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveGeneric #-}++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)++import Network.TLS.Crypto (Group, Hash (..), hash)+import Network.TLS.Imports+import Network.TLS.Types.Cipher+import Network.TLS.Types.Version++-- | A session ID+type SessionID = ByteString++-- | Identity+type SessionIDorTicket = ByteString++-- | Encrypted session ticket (encrypt(encode 'SessionData')).+type Ticket = ByteString++isTicket :: SessionIDorTicket -> Bool+isTicket x+ | B.length x > 32 = True+ | otherwise = False++toSessionID :: Ticket -> SessionID+toSessionID = hash SHA256++-- | Compression identification+type CompressionID = Word8++-- | Session data to resume+data SessionData = SessionData+ { sessionVersion :: Version+ , sessionCipher :: CipherID+ , sessionCompression :: CompressionID+ , sessionClientSNI :: Maybe HostName+ , -- ScrubbedBytes is not an instance of Generic, sigh.+ sessionSecret :: ByteString+ , sessionGroup :: Maybe Group+ , sessionTicketInfo :: Maybe TLS13TicketInfo+ , sessionALPN :: Maybe ByteString+ , sessionMaxEarlyDataSize :: Int+ , sessionFlags :: [SessionFlag]+ } -- sessionFromTicket :: Bool+ deriving (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)+ . showChar '}'++is0RTTPossible :: SessionData -> Bool+is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0++-- | Some session flags+data SessionFlag+ = -- | Session created with Extended Main Secret+ SessionEMS+ deriving (Show, Eq, Enum, Generic)++type Second = Word32+type Millisecond = Word64++data TLS13TicketInfo = TLS13TicketInfo+ { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds+ , ageAdd :: Second -- NewSessionTicket.ticket_age_add+ , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime+ , estimatedRTT :: Maybe Millisecond+ }+ deriving (Show, Eq, Generic)++instance Serialise TLS13TicketInfo+instance Serialise SessionFlag+instance Serialise SessionData
+ Network/TLS/Types/Version.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}++module Network.TLS.Types.Version (+ Version (Version, SSL2, SSL3, TLS10, TLS11, TLS12, TLS13),+) where++import Codec.Serialise+import GHC.Generics++import Network.TLS.Imports++-- | Versions known to TLS+newtype Version = Version Word16 deriving (Eq, Ord, Generic)++{- FOURMOLU_DISABLE -}+pattern SSL2 :: Version+pattern SSL2 = Version 0x0002+pattern SSL3 :: Version+pattern SSL3 = Version 0x0300+pattern TLS10 :: Version+pattern TLS10 = Version 0x0301+pattern TLS11 :: Version+pattern TLS11 = Version 0x0302+pattern TLS12 :: Version+pattern TLS12 = Version 0x0303+pattern TLS13 :: Version+pattern TLS13 = Version 0x0304++instance Show Version where+ show SSL2 = "SSL2"+ show SSL3 = "SSL3"+ show TLS10 = "TLS1.0"+ show TLS11 = "TLS1.1"+ show TLS12 = "TLS1.2"+ show TLS13 = "TLS1.3"+ show (Version x) = "Version " ++ show x+{- FOURMOLU_ENABLE -}++instance Serialise Version
Network/TLS/Util.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.TLS.Util ( sub,@@ -16,12 +17,13 @@ restoreMVar, ) where +import Control.Concurrent.MVar+import qualified Control.Exception as E+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B-import Network.TLS.Imports -import Control.Concurrent.Async-import Control.Concurrent.MVar-import Control.Exception (SomeException)+import Network.TLS.Imports sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len@@ -46,18 +48,24 @@ (p3, _) = B.splitAt d3 r2 partition6- :: ByteString+ :: ScrubbedBytes -> (Int, Int, Int, Int, Int, Int)- -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString)-partition6 bytes (d1, d2, d3, d4, d5, d6) = if B.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6)+ -> Maybe+ ( ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ )+partition6 bytes (d1, d2, d3, d4, d5, d6) = if BA.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6) where- s = sum [d1, d2, d3, d4, d5, d6]- (p1, r1) = B.splitAt d1 bytes- (p2, r2) = B.splitAt d2 r1- (p3, r3) = B.splitAt d3 r2- (p4, r4) = B.splitAt d4 r3- (p5, r5) = B.splitAt d5 r4- (p6, _) = B.splitAt d6 r5+ slice' (beg, len) = BA.unsafeSlice bytes beg len+ lens = [d1, d2, d3, d4, d5, d6]+ s = sum lens+ begs = scanl (+) 0 lens+ ys = zip begs lens+ [p1, p2, p3, p4, p5, p6] = map slice' ys -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool@@ -69,8 +77,13 @@ fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f = fmap f -catchException :: IO a -> (SomeException -> IO a) -> IO a-catchException action handler = withAsync action waitCatch >>= either handler return+catchException :: IO a -> (E.SomeException -> IO a) -> IO a+catchException f handler = E.catchJust filterExn f handler+ where+ filterExn :: E.SomeException -> Maybe E.SomeException+ filterExn e = case E.fromException (E.toException e) of+ Just (E.SomeAsyncException _) -> Nothing+ Nothing -> Just e forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b]) forEitherM [] _ = return (pure [])@@ -82,12 +95,12 @@ mapChunks_ :: Monad m => Maybe Int- -> (B.ByteString -> m a)- -> B.ByteString+ -> (ByteString -> m a)+ -> ByteString -> m () mapChunks_ len f = mapM_ f . getChunks len -getChunks :: Maybe Int -> B.ByteString -> [B.ByteString]+getChunks :: Maybe Int -> ByteString -> [ByteString] getChunks Nothing = (: []) getChunks (Just len) = go where
Network/TLS/Util/ASN1.hs view
@@ -7,6 +7,7 @@ import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.Types (ASN1Object, fromASN1, toASN1)+ import Network.TLS.Imports -- | Attempt to decode a bytestring representing
Network/TLS/Wire.hs view
@@ -50,8 +50,10 @@ import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put++import Network.TLS.Error import Network.TLS.Imports-import Network.TLS.Struct+import Network.TLS.Types import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a@@ -91,7 +93,10 @@ getWord16 = getWord16be getWords16 :: Get [Word16]-getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16+getWords16 = do+ lenb <- getWord16+ when (odd lenb) $ fail "length for ciphers must be even"+ replicateM (fromIntegral lenb `shiftR` 1) getWord16 getWord24 :: Get Int getWord24 = do
Network/TLS/X509.hs view
@@ -10,12 +10,14 @@ CertificateUsage (..), CertificateStore, ValidationCache,+ defaultValidationCache, exceptionValidationCache, validateDefault, FailedReason, ServiceID, wrapCertificateChecks, pubkeyType,+ validateClientCertificate, ) where import Data.X509@@ -58,3 +60,23 @@ pubkeyType :: PubKey -> String pubkeyType = show . pubkeyToAlg++-- | A utility function for client authentication which can be used+-- `onClientCertificate`.+--+-- Since: 2.1.7+validateClientCertificate+ :: CertificateStore+ -> ValidationCache+ -> CertificateChain+ -> IO CertificateUsage+validateClientCertificate store cache cc =+ wrapCertificateChecks+ <$> validate+ HashSHA256+ defaultHooks+ defaultChecks{checkFQHN = False}+ store+ cache+ ("", mempty)+ cc
test/Arbitrary.hs view
@@ -5,15 +5,9 @@ import Control.Monad import qualified Data.ByteString as B-import Data.Default.Class import Data.List import Data.Word-import Data.X509 (- CertificateChain (..),- ExtKeyUsageFlag,- certPubKey,- getCertificate,- )+import Data.X509 (ExtKeyUsageFlag) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Internal@@ -56,12 +50,12 @@ arbitrary = shuffle supportedSignatureSchemes instance Arbitrary DigitallySigned where- arbitrary = DigitallySigned <$> (head <$> arbitrary) <*> genByteString 32+ arbitrary = DigitallySigned . unsafeHead <$> arbitrary <*> genByteString 32 instance Arbitrary ExtensionRaw where arbitrary = let arbitraryContent = choose (0, 40) >>= genByteString- in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent+ in ExtensionRaw . ExtensionID <$> arbitrary <*> arbitraryContent instance Arbitrary CertificateType where arbitrary =@@ -71,28 +65,38 @@ , CertificateType_ECDSA_Sign ] +instance Arbitrary CipherId where+ arbitrary = CipherId <$> arbitrary+ instance Arbitrary Handshake where arbitrary = oneof [ arbitrary >>= \ver -> do- ClientHello ver- <$> arbitrary- <*> arbitraryCompressionIDs- <*> (CH <$> arbitrary <*> arbitraryCiphersIDs <*> arbitraryHelloExtensions ver)+ ClientHello+ <$> ( CH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitraryCiphersIds+ <*> arbitraryCompressionIDs+ <*> arbitraryHelloExtensions ver+ ) , arbitrary >>= \ver ->- ServerHello ver- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver- , Certificate . CertificateChain <$> resize 2 (listOf arbitraryX509)+ ServerHello+ <$> ( SH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitraryHelloExtensions ver+ )+ , Certificate . CertificateChain_ . CertificateChain+ <$> resize 2 (listOf arbitraryX509) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg . CKX_RSA <$> genByteString 48 , CertRequest <$> arbitrary <*> arbitrary <*> listOf arbitraryDN , CertVerify <$> arbitrary- , Finished <$> genByteString 12+ , Finished . VerifyData <$> genByteString 12 ] instance Arbitrary Handshake13 where@@ -100,15 +104,18 @@ oneof [ arbitrary >>= \ver -> ServerHello13- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver+ <$> ( SH TLS12+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> pure 0+ <*> arbitraryHelloExtensions ver+ ) , NewSessionTicket13 <$> arbitrary <*> arbitrary- <*> genByteString 32 -- nonce- <*> genByteString 32 -- session ID+ <*> (TicketNonce <$> genByteString 32) -- nonce+ <*> (SessionIDorTicket_ <$> genByteString 32) -- session ID <*> arbitrary , pure EndOfEarlyData13 , EncryptedExtensions13 <$> arbitrary@@ -118,17 +125,21 @@ , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 <$> arbitraryCertReqContext- <*> return (CertificateChain certs)+ <*> return (CertificateChain_ (CertificateChain certs)) <*> replicateM (length certs) arbitrary- , CertVerify13 <$> (head <$> arbitrary) <*> genByteString 32- , Finished13 <$> genByteString 12+ , CertVerify13+ <$> ( DigitallySigned . unsafeHead+ <$> arbitrary+ <*> genByteString 32+ )+ , Finished13 . VerifyData <$> genByteString 12 , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] ] ---------------------------------------------------------------- -arbitraryCiphersIDs :: Gen [Word16]-arbitraryCiphersIDs = choose (0, 200) >>= vector+arbitraryCiphersIds :: Gen [CipherId]+arbitraryCiphersIds = map CipherId <$> (choose (0, 200) >>= vector) arbitraryCompressionIDs :: Gen [Word8] arbitraryCompressionIDs = choose (0, 200) >>= vector@@ -305,11 +316,13 @@ -- versions for which we have compatible ciphers. Criteria about cipher -- ensure we can test version downgrade. let allowedVersions =- [ v | v <- knownVersions, or- [ x `elem` serverCiphers- && cipherAllowedForVersion v x- | x <- clientCiphers- ]+ [ v+ | v <- knownVersions+ , or+ [ x `elem` serverCiphers+ && cipherAllowedForVersion v x+ | x <- clientCiphers+ ] ] allowedVersionsFiltered = filter (<= connectVersion) allowedVersions -- Server or client is allowed to have versions > connectVersion, but not@@ -361,21 +374,22 @@ clientHashSignatures <- arbitrary serverHashSignatures <- arbitrary let serverState =- def+ defaultParamsServer { serverSupported =- def+ defaultSupported { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg- , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures+ , supportedGroups = serverGroups+ , supportedGroupsTLS13 = [serverGroups] }- , serverShared = def{sharedCredentials = Credentials creds}+ , serverShared = defaultShared{sharedCredentials = Credentials creds} } let clientState = (defaultParamsClient "" B.empty) { clientSupported =- def+ defaultSupported { supportedCiphers = clientCiphers , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg@@ -383,7 +397,7 @@ , supportedHashSignatures = clientHashSignatures } , clientShared =- def+ defaultShared { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return ()@@ -394,7 +408,7 @@ return (clientState, serverState) arbitraryClientCredential :: Version -> Gen Credential-arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements+arbitraryClientCredential _ = arbitraryCredentialsOfEachCurve' >>= elements arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey)@@ -431,3 +445,8 @@ genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i++-- Just for preventing warnings of GHC 9.10+unsafeHead :: [a] -> a+unsafeHead [] = error "unsafeHead"+unsafeHead (x : _) = x
test/Certificate.hs view
@@ -6,9 +6,11 @@ arbitraryX509, arbitraryX509WithKey, arbitraryX509WithKeyAndUsage,+ arbitraryRSACredentialWithPurpose, arbitraryDN, simpleCertificate, simpleX509,+ getSignatureALG, toPubKeyEC, toPrivKeyEC, ) where@@ -116,6 +118,25 @@ let sigalg = getSignatureALG pubKey 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
test/CiphersSpec.hs view
@@ -1,5 +1,6 @@ module CiphersSpec where +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -52,8 +53,8 @@ decrypted `shouldBe` t at `shouldBe` at2 -arbitraryKey :: Bulk -> Gen B.ByteString-arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk)+arbitraryKey :: Bulk -> Gen BA.ScrubbedBytes+arbitraryKey bulk = BA.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk)@@ -61,7 +62,8 @@ arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) -data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString+data BulkTest+ = BulkTest Bulk BA.ScrubbedBytes B.ByteString B.ByteString B.ByteString deriving (Show, Eq) instance Arbitrary BulkTest where
+ test/ECHSpec.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module ECHSpec (spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as L+import Data.Maybe+import Network.TLS+import Network.TLS.ECH.Config+import Network.TLS.Extra.Cipher+import Network.TLS.Internal+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Arbitrary+import Run+import Session++spec :: Spec+spec = do+ describe "ECH" $ do+ 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 EC groups" handshake13_ec+ prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe+ describe "ECH greasing" $ do+ prop "sends greasing ECH" handshake13_greasing+ prop "sends greasing ECH HRR" handshake13_greasing_hrr++--------------------------------------------------------------++newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP13 where+ arbitrary = CSP13 <$> arbitraryPairParams13++--------------------------------------------------------------++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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH 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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH 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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13ECH 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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers0 = twoSessionManagers sessionRefs+ sessionManagers = (fst sessionManagers0, oneSessionTicket)++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13ECH 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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH 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]]+ }++ runTLSSimple13ECH (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 =+ setParams+ ( cli+ { clientSupported = cliSupported+ , clientHooks = cliHooks+ }+ , srv+ { serverSupported = svrSupported+ , serverHooks = svrHooks+ , serverEarlyDataSize = 2048+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH 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)++ runTLS0RTTech 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 =+ setParams+ ( 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+ runTLSSimple13ECH 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 runTLS0RTTech 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_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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH 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 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_greasing :: CSP13 -> IO ()+handshake13_greasing (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+ , clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ , srv{serverSupported = svrSupported}+ )+ (clientMessages, _) <- runTLSCaptureFail params+ let isGreasing (ExtensionRaw eid _) = eid == EID_EncryptedClientHello+ eeMessagesHaveExt =+ [ any isGreasing chExtensions+ | ClientHello CH{..} <- clientMessages+ ]+ eeMessagesHaveExt `shouldBe` [True]++handshake13_greasing_hrr :: CSP13 -> IO ()+handshake13_greasing_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+ , clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ , srv{serverSupported = svrSupported}+ )+ (clientMessages, _) <- runTLSCaptureFail params+ let isGreasing (ExtensionRaw eid _) = eid == EID_EncryptedClientHello+ eeMessagesHaveExt =+ [ any isGreasing chExtensions+ | ClientHello CH{..} <- clientMessages+ ]+ eeMessagesHaveExt `shouldBe` [True, True]++expectJust :: String -> Maybe a -> Expectation+expectJust tag mx = case mx of+ Nothing -> expectationFailure tag+ Just _ -> return ()++setParams :: (ClientParams, ServerParams) -> (ClientParams, ServerParams)+setParams (cli, srv) = (cli', srv')+ where+ cli' =+ cli+ { clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ srv' =+ srv+ { serverECHKey = echKey+ , serverShared = (serverShared srv){sharedECHConfigList = echConfList}+ }++echKey :: [(ConfigId, ByteString)]+echKey = [(0, B64.decodeLenient "GAl/YqzDDnssODe5t+2xlQsbSv26kNlfJ0D+nZbK62I=")]++echConfList :: ECHConfigList+echConfList =+ fromJust $+ decodeECHConfigList $+ B64.decodeLenient+ "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA"
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)+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,36 @@ 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 "encoder/decoder" $ do prop "can encode/decode Header" $ \x -> do decodeHeader (encodeHeader x) `shouldBe` Right x@@ -17,7 +57,151 @@ 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+ decodeHs :: ByteString -> Either TLSError Handshake decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b where@@ -30,6 +214,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 +243,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,1018 +2,2298 @@ module HandshakeSpec where -import Control.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Default.Class-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 head 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_AES256GCM_SHA384- , cipher_ECDHE_ECDSA_AES256GCM_SHA384- , cipher_TLS13_AES128GCM_SHA256- ]- (clientParam, serverParam) <-- generate $- arbitraryPairParamsWithVersionsAndCiphers- ([version], [version])- (ciphers, ciphers)- let clientParam' =- clientParam- { clientSupported =- (clientSupported clientParam)- { supportedHashSignatures = clientHashSigs- }- }- serverParam' =- serverParam- { serverSupported =- (serverSupported serverParam)- { supportedHashSignatures = serverHashSigs- }- }- commonHashSigs = clientHashSigs `intersect` serverHashSigs- shouldFail- | tls13 = all incompatibleWithDefaultCurve commonHashSigs- | otherwise = null commonHashSigs- if shouldFail- then runTLSFailure (clientParam', serverParam') handshake handshake- else runTLSSimple (clientParam', serverParam')- where- incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256- incompatibleWithDefaultCurve _ = False--handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO ()-handshake_ciphersuites (clientCiphers, serverCiphers) = do- tls13 <- generate arbitrary- let version = if tls13 then TLS13 else TLS12- (clientParam, serverParam) <-- generate $- arbitraryPairParamsWithVersionsAndCiphers- ([version], [version])- (clientCiphers, serverCiphers)- let adequate = cipherAllowedForVersion version- shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers)- if shouldSucceed- then runTLSSimple (clientParam, serverParam)- else runTLSFailure (clientParam, serverParam) handshake handshake------------------------------------------------------------------handshake_groups :: GGP -> IO ()-handshake_groups (GGP clientGroups serverGroups) = do- tls13 <- generate arbitrary- let versions = if tls13 then [TLS13] else [TLS12]- ciphers = ciphersuite_strong- (clientParam, serverParam) <-- generate $- arbitraryPairParamsWithVersionsAndCiphers- (versions, versions)- (ciphers, ciphers)- denyCustom <- generate arbitrary- let groupUsage =- if denyCustom- then GroupUsageUnsupported "custom group denied"- else GroupUsageValid- clientParam' =- clientParam- { clientSupported =- (clientSupported clientParam)- { supportedGroups = clientGroups- }- , clientHooks =- (clientHooks clientParam)- { onCustomFFDHEGroup = \_ _ -> return groupUsage- }- }- serverParam' =- serverParam- { serverSupported =- (serverSupported serverParam)- { supportedGroups = serverGroups- }- }- commonGroups = clientGroups `intersect` serverGroups- shouldFail = null commonGroups- p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups- if shouldFail- then runTLSFailure (clientParam', serverParam') handshake handshake- else runTLSPredicate (clientParam', serverParam') p------------------------------------------------------------------newtype SG = SG [Group] deriving (Show)--instance Arbitrary SG where- arbitrary = SG <$> shuffle sigGroups- where- sigGroups = [P256, P521]--handshake_ec :: SG -> IO ()-handshake_ec (SG sigGroups) = do- let versions = [TLS12]- ciphers =- [ cipher_ECDHE_ECDSA_AES256GCM_SHA384- ]- hashSignatures =- [ (HashSHA256, SignatureECDSA)- ]- (clientParam, serverParam) <-- generate $- arbitraryPairParamsWithVersionsAndCiphers- (versions, versions)- (ciphers, ciphers)- clientGroups <- generate $ shuffle sigGroups- clientHashSignatures <- generate $ sublistOf hashSignatures- serverHashSignatures <- generate $ sublistOf hashSignatures- credentials <- generate arbitraryCredentialsOfEachCurve- let clientParam' =- clientParam- { clientSupported =- (clientSupported clientParam)- { supportedGroups = clientGroups- , supportedHashSignatures = clientHashSignatures- }- }- serverParam' =- serverParam- { serverSupported =- (serverSupported serverParam)- { supportedGroups = sigGroups- , supportedHashSignatures = serverHashSignatures- }- , serverShared =- (serverShared serverParam)- { sharedCredentials = Credentials credentials- }- }- sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures)- ecdsaDenied = SignatureECDSA `notElem` sigAlgs- if ecdsaDenied- then runTLSFailure (clientParam', serverParam') handshake handshake- else runTLSSimple (clientParam', serverParam')---- Tests ability to use or ignore client "signature_algorithms" extension when--- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but--- the server RSA certificate has a SHA-1 signature that the client does not--- support. Server may choose the DSA certificate only when cipher--- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA--- certificate.--data OC = OC [Cipher] [Cipher] deriving (Show)--instance Arbitrary OC where- arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers- where- otherCiphers =- [ cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_AES128GCM_SHA256- ]--handshake_cert_fallback_cipher :: OC -> IO ()-handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do- let clientVersions = [TLS12]- serverVersions = [TLS12]- commonCiphers = [cipher_ECDHE_RSA_AES128GCM_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_AES128GCM_SHA256- , cipher_ECDHE_ECDSA_AES128GCM_SHA256- , cipher_TLS13_AES128GCM_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 =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- params =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )- runTLSSimple13 params FullHandshake--handshake13_hrr :: CSP13 -> IO ()-handshake13_hrr (CSP13 (cli, srv)) = do- let cliSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [P256, X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- params =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )- runTLSSimple13 params HelloRetryRequest--handshake13_psk :: CSP13 -> IO ()-handshake13_psk (CSP13 (cli, srv)) = do- let cliSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [P256, X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- params0 =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )-- sessionRefs <- twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params = setPairParamsSessionManagers sessionManagers params0-- runTLSSimple13 params HelloRetryRequest-- -- and resume- sessionParams <- readClientSessionRef sessionRefs- expectJust "session param should be Just" sessionParams- let params2 = setPairParamsSessionResuming (fromJust sessionParams) params-- runTLSSimple13 params2 PreSharedKey--handshake13_psk_ticket :: CSP13 -> IO ()-handshake13_psk_ticket (CSP13 (cli, srv)) = do- let cliSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [P256, X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- params0 =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )-- sessionRefs <- twoSessionRefs- let sessionManagers0 = twoSessionManagers sessionRefs- sessionManagers = (fst sessionManagers0, oneSessionTicket)-- let params = setPairParamsSessionManagers sessionManagers params0-- runTLSSimple13 params HelloRetryRequest-- -- and resume- sessionParams <- readClientSessionRef sessionRefs- expectJust "session param should be Just" sessionParams- let params2 = setPairParamsSessionResuming (fromJust sessionParams) params-- runTLSSimple13 params2 PreSharedKey--handshake13_psk_fallback :: CSP13 -> IO ()-handshake13_psk_fallback (CSP13 (cli, srv)) = do- let cliSupported =- def- { supportedCiphers =- [ cipher_TLS13_AES128GCM_SHA256- , cipher_TLS13_AES128CCM_SHA256- ]- , supportedGroups = [P256, X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- params0 =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )-- sessionRefs <- twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params = setPairParamsSessionManagers sessionManagers params0-- runTLSSimple13 params HelloRetryRequest-- -- resumption fails because GCM cipher is not supported anymore, full- -- handshake is not possible because X25519 has been removed, so we are- -- back with P256 after hello retry- sessionParams <- readClientSessionRef sessionRefs- expectJust "session param should be Just" sessionParams- let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params- srv2' = srv2{serverSupported = svrSupported'}- svrSupported' =- def- { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256]- , supportedGroups = [P256]- }-- runTLSSimple13 (cli2, srv2') HelloRetryRequest--handshake13_0rtt :: CSP13 -> IO ()-handshake13_0rtt (CSP13 (cli, srv)) = do- let cliSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [P256, X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- cliHooks =- def- { onSuggestALPN = return $ Just ["h2"]- }- svrHooks =- def- { onALPNClientSuggest = Just (return . head)- }- 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 =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [P256, X25519]- }- svrSupported =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [group0]- }- params =- ( cli{clientSupported = cliSupported}- , srv- { serverSupported = svrSupported- , serverEarlyDataSize = 1024- }- )-- sessionRefs <- twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params0 = setPairParamsSessionManagers sessionManagers params-- let mode = if group0 == P256 then FullHandshake else HelloRetryRequest- runTLSSimple13 params0 mode-- -- and resume- mSessionParams <- readClientSessionRef sessionRefs- case mSessionParams of- Nothing -> expectationFailure "session params: Just is expected"- Just sessionParams -> do- earlyData <- B.pack <$> generate (someWords8 256)- group1 <- generate $ elements [P256, X25519]- let (pc, ps) = setPairParamsSessionResuming sessionParams params0- svrSupported1 =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [group1]- }- params1 =- ( pc{clientUseEarlyData = True}- , ps- { serverEarlyDataSize = 0- , serverSupported = svrSupported1- }- )- -- C: [P256, X25519]- -- S: [group0]- -- C: [P256, X25519]- -- S: [group1]- if group0 == group1- -- 0-RTT is not allowed, so fallback to PreSharedKey- then runTLS0RTT params1 PreSharedKey earlyData- -- HRR but not allowed for 0-RTT- else runTLSFailure params1 (tlsClient earlyData) tlsServer- where- tlsClient earlyData ctx = do- handshake ctx- sendData ctx $ L.fromStrict earlyData- _ <- recvData ctx- bye ctx- tlsServer ctx = do- handshake ctx- _ <- recvData ctx- bye ctx--handshake13_ee_groups :: CSP13 -> IO ()-handshake13_ee_groups (CSP13 (cli, srv)) = do- let -- The client prefers P256- cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]}- -- The server prefers X25519- svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]}- params =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )- (_, serverMessages) <- runTLSCapture13 params- -- The server should tell X25519 in supported_groups in EE to clinet- let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups- eeMessagesHaveExt =- [ any isSupportedGroups exts- | EncryptedExtensions13 exts <- serverMessages- ]- eeMessagesHaveExt `shouldBe` [True]--handshake13_ec :: CSP13 -> IO ()-handshake13_ec (CSP13 (cli, srv)) = do- EC cgrps <- generate arbitrary- EC sgrps <- generate arbitrary- let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}- params =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )- runTLSSimple13 params FullHandshake--handshake13_ffdhe :: CSP13 -> IO ()-handshake13_ffdhe (CSP13 (cli, srv)) = do- FFDHE cgrps <- generate arbitrary- FFDHE sgrps <- generate arbitrary- let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}- params =- ( cli{clientSupported = cliSupported}- , srv{serverSupported = svrSupported}- )- runTLSSimple13 params FullHandshake--post_handshake_auth :: CSP13 -> IO ()-post_handshake_auth (CSP13 (clientParam, serverParam)) = do- cred <- generate (arbitraryClientCredential TLS13)- let clientParam' =- clientParam- { clientHooks =- (clientHooks clientParam)- { onCertificateRequest = \_ -> return $ Just cred- }- }- serverParam' =- serverParam- { serverHooks =- (serverHooks serverParam)- { onClientCertificate = validateChain cred- }- }- if isCredentialDSA cred- then runTLSFailure (clientParam', serverParam') hsClient hsServer- else runTLSSuccess (clientParam', serverParam') hsClient hsServer- where- validateChain cred chain- | chain == fst cred = return CertificateUsageAccept- | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)- hsClient ctx = do- handshake ctx- sendData ctx "request 1"- recvDataAssert ctx "response 1"- sendData ctx "request 2"- recvDataAssert ctx "response 2"- hsServer ctx = do- handshake ctx- recvDataAssert ctx "request 1"- _ <- requestCertificate ctx -- single request- sendData ctx "response 1"- recvDataAssert ctx "request 2"- _ <- requestCertificate ctx- _ <- requestCertificate ctx -- two simultaneously- sendData ctx "response 2"+import Control.Concurrent (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 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 Network.TLS+import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC+import Network.TLS.Internal+import Network.TLS.QUIC (hkdfExpandLabel)+import Test.Hspec+import Test.Hspec.QuickCheck+import System.Timeout (timeout)+import Test.QuickCheck++import API+import Arbitrary+import Certificate (arbitraryRSACredentialWithPurpose)+import PipeChan+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+ 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 "ignores legacy_version when supported_versions is present" $+ handshake_high_legacy_version TLS13 TLS13+ 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+ 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 TLS 1.2 CertificateVerify algorithm for another key type" $+ handshake12_client_cert_verify_sigalg+ (HashSHA256, SignatureECDSA)+ rejectedAsIllegalParameter+ it "rejects a TLS 1.2 CertificateVerify that does not fit the RSA key" $+ handshake12_client_cert_verify_sigalg+ (HashIntrinsic, SignatureRSApsspssSHA256)+ rejectedAsDecryptError+ 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 "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 "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+ 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+ 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+ 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+ 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 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 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++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_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++--------------------------------------------------------------++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)++-- 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+ :: HashAndSignatureAlgorithm -> 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 == (HashSHA256, SignatureECDSA)+ 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++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 (HashIntrinsic, SignatureRSApsspssSHA256) 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 negotiates the highest version it supports (RFC 5246 Appendix+-- E.1); with supported_versions present it does not use legacy_version at+-- all (RFC 8446 Section 4.2.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++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 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++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++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"++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 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"++-- | 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))+ )++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, protected under+-- its application traffic secret, a record holding only the first two bytes+-- of a KeyUpdate and then a record of application data. The server must not+-- deliver the data and must answer with unexpected_message.+handshake13_interleaved_app_data :: IO ()+handshake13_interleaved_app_data = 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_+ ( do+ handshake sctx+ r <- E.try (recvData sctx) :: IO (Either TLSException B.ByteString)+ case r of+ Right d -> expectationFailure $ "server delivered " ++ show d+ Left _ -> return ()+ )+ ( 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+ -- the first two bytes of KeyUpdate(update_not_requested)+ partialKeyUpdate = B.pack [24, 0]+ send $ protect13 key iv 0 22 partialKeyUpdate+ send $ protect13 key iv 1 23 "hello"+ recvData cctx `shouldThrow` peerSentUnexpected+ )+ where+ unhex [] = B.empty+ unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest)+ unhex _ = error "unhex"++-- 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
@@ -91,6 +91,7 @@ knownECCurves = [ ECC.SEC_p256r1 , ECC.SEC_p384r1+ , ECC.SEC_p521r1 ] defaultECCurve :: ECC.CurveName
test/Run.hs view
@@ -6,12 +6,21 @@ runTLSSimple, runTLSPredicate, runTLSSimple13,+ runTLSSimple13ECH, runTLS0RTT,+ runTLS0RTTech, runTLSSimpleKeyUpdate,+ runTLSCaptureFail, runTLSCapture13, runTLSSuccess, runTLSFailure, expectMaybe,+ newPairContext,+ newPairContextWith,+ withPairContext,+ withPairContextWith,+ withDataPipe,+ byeBye, ) where import Control.Concurrent@@ -21,7 +30,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Default.Class import Data.IORef import Network.TLS import System.Timeout@@ -119,6 +127,25 @@ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode +runTLSSimple13ECH+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> IO ()+runTLSSimple13ECH params mode =+ runTLSSuccess params hsClient hsServer+ where+ hsClient ctx = do+ handshake ctx+ minfo <- contextGetInformation ctx+ let mmode = minfo >>= infoTLS13HandshakeMode+ maccepted = infoIsECHAccepted <$> minfo+ expectMaybe "C: mode should be Just" mode mmode+ expectMaybe "C: TLS accepted should be Just" True maccepted+ hsServer ctx = do+ handshake ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "S: mode should be Just" mode mmode+ runTLS0RTT :: (ClientParams, ServerParams) -> HandshakeMode13@@ -132,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@@ -141,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@@ -150,11 +189,80 @@ | len > 0 = [len] | otherwise = [] +runTLS0RTTech+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> ByteString+ -> IO ()+runTLS0RTTech params mode earlyData =+ withPairContext params $ \(cCtx, sCtx) ->+ concurrently_ (tlsServer sCtx) (tlsClient cCtx)+ where+ tlsClient ctx = do+ 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+ maccepted = infoIsECHAccepted <$> minfo+ expectMaybe "C: mode should be Just" mode mmode+ expectMaybe "C: TLS accepted should be Just" True maccepted+ tlsServer ctx = do+ handshake ctx+ let ls = chunkLengths $ B.length earlyData+ 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+ chunkLengths :: Int -> [Int]+ chunkLengths len+ | len > 16384 = 16384 : chunkLengths (len - 16384)+ | len > 0 = [len]+ | otherwise = []+ expectMaybe :: (Show a, Eq a) => String -> a -> Maybe a -> Expectation expectMaybe tag e mx = case mx of Nothing -> expectationFailure tag Just x -> x `shouldBe` e +runTLSCaptureFail+ :: (ClientParams, ServerParams) -> IO ([Handshake], [Handshake])+runTLSCaptureFail params = do+ sRef <- newIORef []+ cRef <- newIORef []+ runTLSFailure params (hsClient cRef) (hsServer sRef)+ sReceived <- readIORef sRef+ cReceived <- readIORef cRef+ return (reverse sReceived, reverse cReceived)+ where+ hsClient ref ctx = do+ installHook ctx ref+ handshake ctx+ sendData ctx "Foo"+ hsServer ref ctx = do+ installHook ctx ref+ handshake ctx+ _ <- recvData ctx+ return ()+ installHook ctx ref =+ let recv hss = modifyIORef ref (hss :) >> return hss+ in contextHookSetHandshakeRecv ctx recv+ runTLSCapture13 :: (ClientParams, ServerParams) -> IO ([Handshake13], [Handshake13]) runTLSCapture13 params = do@@ -214,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@@ -245,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 ())+ -> IO ()+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 ()@@ -262,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: ")@@ -273,8 +401,41 @@ logging pre = if debug then- def+ defaultLogging { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) }- else def+ else defaultLogging+++withDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> ((start -> IO (), IO result) -> IO a) -> IO a+withDataPipe params tlsServer tlsClient cont = do+ -- initial setup+ startQueue <- newChan+ resultQueue <- newChan++ (cCtx, sCtx) <- snd <$> newPairContext params++ withAsync (E.catch (tlsServer sCtx resultQueue)+ (printAndRaise "server" (serverSupported $ snd params))) $ \sAsync -> withAsync (E.catch (tlsClient startQueue cCtx)+ (printAndRaise "client" (clientSupported $ fst params))) $ \cAsync -> do+ let readResult = waitBoth cAsync sAsync >> readChan resultQueue+ cont (writeChan startQueue, readResult)++ where+ printAndRaise :: String -> Supported -> E.SomeException -> IO ()+ printAndRaise s supported e = do+ putStrLn $ s ++ " exception: " ++ show e +++ ", supported: " ++ show supported+ E.throwIO e++-- Terminate the write direction and wait to receive the peer EOF. This is+-- necessary in situations where we want to confirm the peer status, or to make+-- sure to receive late messages like session tickets. In the test suite this+-- is used each time application code ends the connection without prior call to+-- 'recvData'.+byeBye :: Context -> IO ()+byeBye ctx = do+ bye ctx+ bs <- recvData ctx+ unless (B.null bs) $ fail "byeBye: unexpected application data"
+ test/SecretSpec.hs view
@@ -0,0 +1,63 @@+{-# 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 = []+ }+ 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
test/Session.hs view
@@ -32,7 +32,7 @@ -- a Real concurrent session manager would use an MVar and have multiples items. oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager oneSessionManager ref =- SessionManager+ noSessionManager { sessionResume = \myId -> readIORef ref >>= maybeResume False myId , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId , sessionEstablish = \myId dat -> writeIORef ref (Just (myId, dat)) >> return Nothing@@ -78,7 +78,7 @@ oneSessionTicket :: SessionManager oneSessionTicket =- SessionManager+ noSessionManager { sessionResume = resume , sessionResumeOnlyOnce = resume , sessionEstablish = \_ dat -> return $ Just $ L.toStrict $ serialise dat
tls.cabal view
@@ -1,6 +1,6 @@-cabal-version: >=1.10+cabal-version: 2.0 name: tls-version: 2.0.6+version: 2.4.9 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -20,7 +20,7 @@ source-repository head type: git location: https://github.com/haskell-tls/hs-tls- subdir: core+ subdir: tls flag devel description: Development commands@@ -34,6 +34,7 @@ Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher+ Network.TLS.Extra.CipherCBC Network.TLS.Extra.FFDHE Network.TLS.QUIC @@ -50,6 +51,7 @@ Network.TLS.Crypto.IES Network.TLS.Crypto.Types Network.TLS.ErrT+ Network.TLS.Error Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Certificate@@ -63,7 +65,6 @@ Network.TLS.Handshake.Common13 Network.TLS.Handshake.Control Network.TLS.Handshake.Key- Network.TLS.Handshake.Process Network.TLS.Handshake.Random Network.TLS.Handshake.Server Network.TLS.Handshake.Server.ClientHello@@ -77,8 +78,12 @@ Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13+ Network.TLS.Handshake.TranscriptHash+ Network.TLS.HashAndSignature Network.TLS.Hooks Network.TLS.IO+ Network.TLS.IO.Decode+ Network.TLS.IO.Encode Network.TLS.Imports Network.TLS.KeySchedule Network.TLS.MAC@@ -87,84 +92,54 @@ Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.PostHandshake+ Network.TLS.RNG Network.TLS.Record- Network.TLS.Record.Disengage- Network.TLS.Record.Engage+ Network.TLS.Record.Decrypt+ Network.TLS.Record.Encrypt Network.TLS.Record.Layer- Network.TLS.Record.Reading- Network.TLS.Record.Writing+ Network.TLS.Record.Recv+ Network.TLS.Record.Send Network.TLS.Record.State Network.TLS.Record.Types- Network.TLS.RNG- Network.TLS.State Network.TLS.Session- Network.TLS.Sending- Network.TLS.Receiving+ Network.TLS.State+ Network.TLS.Types+ Network.TLS.Types.Cipher+ Network.TLS.Types.Secret+ Network.TLS.Types.Session+ Network.TLS.Types.Version Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization- Network.TLS.Types Network.TLS.Wire Network.TLS.X509 + default-language: Haskell2010 default-extensions: Strict StrictData- default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall build-depends: base >=4.9 && <5,- asn1-encoding >= 0.9 && < 0.10,- asn1-types >= 0.3 && < 0.4,- async >= 2.2 && < 2.3, base16-bytestring,- bytestring >= 0.10 && < 0.13,- cereal >= 0.5.3 && < 0.6,- crypton >= 0.34,- crypton-x509 >= 1.7 && < 1.8,- crypton-x509-store >= 1.6 && < 1.7,- crypton-x509-validation >= 1.6.5 && < 1.7,- data-default-class >= 0.1 && < 0.2,- memory >= 0.18 && < 0.19,- mtl >= 2.2 && < 2.4,- network >= 3.1,- serialise >= 0.2 && < 0.3,- transformers >= 0.5 && < 0.7,- unix-time >= 0.4.11 && < 0.5--test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- build-tool-depends: hspec-discover:hspec-discover- hs-source-dirs: test- other-modules:- API- Arbitrary- Certificate- CiphersSpec- EncodeSpec- HandshakeSpec- PipeChan- PubKey- Run- Session- ThreadSpec-- default-extensions: Strict StrictData- default-language: Haskell2010- ghc-options: -Wall -threaded -rtsopts- build-depends:- base >=4.9 && <5,- QuickCheck,- asn1-types,- async,- bytestring,- crypton,- crypton-x509,- crypton-x509-validation,- data-default-class,- hourglass,- hspec,- serialise,- tls+ bytestring >=0.10 && <0.13,+ cereal >=0.5.3 && <0.6,+ crypton >=2.1.1 && <2.2,+ crypton-asn1-encoding >= 0.10.0 && < 0.11,+ crypton-asn1-types >= 0.4.1 && < 0.5,+ crypton-x509 >=1.9 && <1.10,+ crypton-x509-store >=1.9 && <1.10,+ crypton-x509-validation >=1.9 && <1.10,+ data-default,+ ech-config,+ hpke >=0.1.0 && <0.3,+ mlkem >= 0.2.0 && <0.3,+ mtl >=2.2 && <2.4,+ network >=3.1,+ ram >=0.22.0 && <0.23,+ random >=1.2 && <1.4,+ serialise >=0.2 && <0.3,+ transformers >=0.5 && <0.7,+ unix-time >=0.4.11 && <0.6,+ zlib >=0.7 && <0.8 executable tls-server main-is: tls-server.hs@@ -179,16 +154,16 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5,+ base16-bytestring, bytestring, containers, crypton, crypton-x509-store, crypton-x509-system,- data-default-class,+ ech-config, network, network-run,- tls,- unliftio+ tls if flag(devel) @@ -208,17 +183,101 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5,+ base16-bytestring, bytestring, crypton, crypton-x509-store, crypton-x509-system,- data-default-class,+ ech-config, network,- network-run,- tls,- unliftio+ network-run >=0.6.0 && < 0.7,+ tls if flag(devel) else buildable: False++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test+ other-modules:+ API+ Arbitrary+ Certificate+ CiphersSpec+ ECHSpec+ EncodeSpec+ HandshakeSpec+ PipeChan+ PubKey+ Run+ SecretSpec+ Session+ ThreadSpec++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall -threaded -rtsopts+ build-depends:+ base >=4.9 && <5,+ QuickCheck,+ async,+ base64-bytestring,+ bytestring,+ crypton,+ crypton-asn1-types,+ crypton-x509,+ crypton-x509-validation,+ ech-config,+ hspec,+ ram,+ serialise,+ time-hourglass,+ tls,+ zlib++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,+ ram,+ serialise,+ tasty-bench,+ time-hourglass,+ tls
util/Client.hs view
@@ -4,10 +4,15 @@ module Client ( Aux (..), Cli,- client,+ clientHTTP11,+ clientDNS, ) where +import qualified Data.ByteString.Base16 as BS16+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as CL8+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE import Network.Socket import Network.TLS @@ -16,29 +21,41 @@ data Aux = Aux { auxAuthority :: HostName , auxPort :: ServiceName- , auxDebug :: String -> IO ()+ , auxDebugPrint :: String -> IO () , auxShow :: ByteString -> IO ()- , auxReadResumptionData :: IO (Maybe (SessionID, SessionData))+ , auxReadResumptionData :: IO [(SessionID, SessionData)] } -type Cli = Aux -> [ByteString] -> Context -> IO ()+type Cli = Aux -> NonEmpty ByteString -> Context -> IO () -client :: Cli-client Aux{..} paths ctx = do+clientHTTP11 :: Cli+clientHTTP11 aux@Aux{..} paths ctx = do sendData ctx $- "GET "- <> CL8.fromStrict (head paths)- <> " HTTP/1.1\r\n"- <> "Host: "- <> CL8.pack auxAuthority- <> "\r\n"- <> "Connection: close\r\n"- <> "\r\n"- loop+ CL8.fromStrict $+ "GET "+ <> NE.head paths+ <> " HTTP/1.1\r\n"+ <> "Host: "+ <> C8.pack auxAuthority+ <> "\r\n"+ <> "Connection: close\r\n"+ <> "\r\n"+ consume ctx aux++clientDNS :: Cli+clientDNS Aux{..} _paths ctx = do+ sendData+ ctx+ "\x00\x2c\xdc\xe3\x01\x00\x00\x01\x00\x00\x00\x00\x00\x01\x03\x77\x77\x77\x07\x65\x78\x61\x6d\x70\x6c\x65\x03\x63\x6f\x6d\x00\x00\x01\x00\x01\x00\x00\x29\x04\xd0\x00\x00\x00\x00\x00\x00"+ bs <- recvData ctx+ auxShow $ "Reply: " <> BS16.encode bs auxShow "\n"++consume :: Context -> Aux -> IO ()+consume ctx Aux{..} = loop where loop = do bs <- recvData ctx- when (bs /= "") $ do- auxShow bs- loop+ if bs == ""+ then auxShow "\n"+ else auxShow bs >> loop
util/Common.hs view
@@ -3,11 +3,9 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Common (- printCiphers, printDHParams, printGroups, readNumber,- readCiphers, readDHParams, readGroups, getCertificateStore,@@ -15,15 +13,15 @@ namedGroups, getInfo, printHandshakeInfo,+ showBytesHex, ) where -import Crypto.System.CPU+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as C8 import Data.Char (isDigit) import Data.X509.CertificateStore import Network.TLS hiding (HostName)-import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE-import Numeric (showHex) import System.Exit import System.X509 @@ -38,38 +36,33 @@ , ("ffdhe8192", ffdhe8192) ] -namedCiphersuites :: [(String, [CipherID])]-namedCiphersuites =- [ ("all", map cipherID ciphersuite_all)- , ("default", map cipherID ciphersuite_default)- , ("strong", map cipherID ciphersuite_strong)- ]-+{- FOURMOLU_DISABLE -} namedGroups :: [(String, Group)] namedGroups =- [ ("ffdhe2048", FFDHE2048)- , ("ffdhe3072", FFDHE3072)- , ("ffdhe4096", FFDHE4096)- , ("ffdhe6144", FFDHE6144)- , ("ffdhe8192", FFDHE8192)- , ("p256", P256)- , ("p384", P384)- , ("p521", P521)- , ("x25519", X25519)- , ("x448", X448)+ [ ("ffdhe2048", FFDHE2048)+ , ("ffdhe3072", FFDHE3072)+ , ("ffdhe4096", FFDHE4096)+ , ("ffdhe6144", FFDHE6144)+ , ("ffdhe8192", FFDHE8192)+ , ("p256", P256)+ , ("p384", P384)+ , ("p521", P521)+ , ("x25519", X25519)+ , ("x448", X448)+ , ("mlkem512", MLKEM512)+ , ("mlkem768", MLKEM768)+ , ("mlkem1024", MLKEM1024)+ , ("x25519mlkem768", X25519MLKEM768)+ , ("p256mlkem768", P256MLKEM768)+ , ("p384mlkem1024", P384MLKEM1024) ]+{- FOURMOLU_ENABLE -} readNumber :: (Num a, Read a) => String -> Maybe a readNumber s | all isDigit s = Just $ read s | otherwise = Nothing -readCiphers :: String -> Maybe [CipherID]-readCiphers s =- case lookup s namedCiphersuites of- Nothing -> (: []) `fmap` readNumber s- just -> just- readDHParams :: String -> IO (Maybe DHParams) readDHParams s = case lookup s namedDHParams of@@ -77,37 +70,7 @@ mparams -> return mparams readGroups :: String -> [Group]-readGroups s = case traverse (`lookup` namedGroups) (split ',' s) of- Nothing -> []- Just gs -> gs--printCiphers :: IO ()-printCiphers = do- putStrLn "Supported ciphers"- putStrLn "====================================="- forM_ ciphersuite_all_det $ \c ->- putStrLn- ( pad 50 (cipherName c)- ++ " = "- ++ pad 5 (show $ cipherID c)- ++ " 0x"- ++ showHex (cipherID c) ""- )- putStrLn ""- putStrLn "Ciphersuites"- putStrLn "====================================="- forM_ namedCiphersuites $ \(name, _) -> putStrLn name- putStrLn ""- putStrLn- ("Using crypton-" ++ VERSION_crypton ++ " with CPU support for: " ++ cpuSupport)- where- pad n s- | length s < n = s ++ replicate (n - length s) ' '- | otherwise = s-- cpuSupport- | null processorOptions = "(nothing)"- | otherwise = intercalate ", " (map show processorOptions)+readGroups s = fromMaybe [] $ traverse (`lookup` namedGroups) (split ',' s) printDHParams :: IO () printDHParams = do@@ -125,9 +88,9 @@ split :: Char -> String -> [String] split _ "" = [] split c s = case break (c ==) s of- ("", r) -> split c (tail r)+ ("", _ : rs) -> split c rs (s', "") -> [s']- (s', r) -> s' : split c (tail r)+ (s', _ : rs) -> s' : split c rs getCertificateStore :: [FilePath] -> IO CertificateStore getCertificateStore [] = getSystemCertificateStore@@ -148,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 @@ -164,3 +127,7 @@ when (infoVersion i == TLS13) $ do putStrLn $ "Handshake mode: " ++ show (fromJust (infoTLS13HandshakeMode i)) putStrLn $ "Early data accepted: " ++ show (infoIsEarlyDataAccepted i)+ putStrLn $ "Encrypted client hello accepted: " ++ show (infoIsECHAccepted i)++showBytesHex :: ByteString -> String+showBytesHex bs = C8.unpack $ B16.encode bs
util/Server.hs view
@@ -3,53 +3,93 @@ module Server where import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy.Char8 as CL8 import Data.IORef import Network.TLS import Prelude hiding (getLine) import Imports -server :: Context -> Bool -> IO ()-server ctx showRequest = do- recvRequest ctx showRequest- sendData ctx $+-- "<>" creates *chunks* of lazy ByteString, resulting+-- many TLS fragments.+-- To prevent this, strict ByteString is created first and+-- converted into lazy one.+html :: CL8.ByteString+html =+ CL8.fromStrict $ "HTTP/1.1 200 OK\r\n" <> "Context-Type: text/html\r\n" <> "Content-Length: "- <> BL8.pack (show (BL8.length body))+ <> C8.pack (show (BS.length body)) <> "\r\n" <> "\r\n" <> body where body = "<html><<body>Hello world!</body></html>" -recvRequest :: Context -> Bool -> IO ()-recvRequest ctx showRequest = do- getLine <- newSource ctx- loop getLine+-- 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 ('G', _) -> handleHTML ctx showRequest bs+ Just _ -> do+ sendData ctx $ CL8.fromStrict bs+ echo ctx++echo :: Context -> IO ()+echo ctx = loop where- loop getLine = do+ loop = do+ bs <- recvData ctx+ when (bs /= "") $ do+ sendData ctx $ CL8.fromStrict bs+ loop++handleHTML :: Context -> Bool -> ByteString -> IO ()+handleHTML ctx showRequest ini = do+ getLine <- newSource ctx ini+ process getLine+ where+ 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" when (bs /= "") $ do when showRequest $ do BS.putStr bs BS.putStr "\n"- loop getLine+ consume getLine+ sendData ctx html+ consume getLine = do+ bs <- getLine+ when (bs /= "") $ do+ when showRequest $ do+ BS.putStr bs+ BS.putStr "\n"+ consume getLine -newSource :: Context -> IO (IO ByteString)-newSource ctx = do- ref <- newIORef ""+newSource :: Context -> ByteString -> IO (IO ByteString)+newSource ctx ini = do+ ref <- newIORef ini return $ getline ref where getline :: IORef ByteString -> IO ByteString getline ref = do bs0 <- readIORef ref- case BS.breakSubstring "\r\n" bs0 of+ case BS.breakSubstring "\n" bs0 of (_, "") -> do bs1 <- recvData ctx writeIORef ref (bs0 <> bs1) getline ref (bs1, bs2) -> do- writeIORef ref $ BS.drop 2 bs2- return bs1+ writeIORef ref $ BS.drop 1 bs2+ return $ BS.dropWhileEnd (== 0x0d) bs1
util/tls-client.hs view
@@ -1,22 +1,28 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main where import Control.Concurrent+import qualified Control.Exception as E+import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as C8-import Data.Default.Class (def) import Data.IORef+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE import Data.X509.CertificateStore import Network.Run.TCP import Network.Socket-import Network.TLS+import Network.TLS hiding (is0RTTPossible)+import Network.TLS.ECH.Config+import Network.TLS.Internal (makeCipherShowPretty) import System.Console.GetOpt import System.Environment import System.Exit import System.X509-import qualified UnliftIO.Exception as E import Client import Common@@ -33,6 +39,14 @@ , opt0RTT :: Bool , optRetry :: Bool , optVersions :: [Version]+ , optALPN :: String+ , optCertFile :: Maybe FilePath+ , optKeyFile :: Maybe FilePath+ , optECHConfigFile :: Maybe FilePath+ , optTraceKey :: Bool+ , optIPv4Only :: Bool+ , optIPv6Only :: Bool+ , optTrustedAnchor :: Maybe FilePath } deriving (Show) @@ -42,17 +56,25 @@ { optDebugLog = False , optShow = False , optKeyLogFile = Nothing- , optGroups = supportedGroups def+ , optGroups = supportedGroups defaultSupported , optValidate = False , optVerNego = False , optResumption = False , opt0RTT = False , optRetry = False- , optVersions = supportedVersions def+ , optVersions = supportedVersions defaultSupported+ , optALPN = "http/1.1"+ , optCertFile = Nothing+ , optKeyFile = Nothing+ , optECHConfigFile = Nothing+ , optTraceKey = False+ , optIPv4Only = False+ , optIPv6Only = False+ , optTrustedAnchor = Nothing } usage :: String-usage = "Usage: quic-client [OPTION] addr port [path]"+usage = "Usage: tls-client [OPTION] addr port [path]" options :: [OptDescr (Options -> Options)] options =@@ -106,13 +128,53 @@ ["tls13"] (NoArg (\o -> o{optVersions = [TLS13]})) "use TLS 1.3"+ , Option+ ['a']+ ["alpn"]+ (ReqArg (\a o -> o{optALPN = a}) "<alpn>")+ "set ALPN"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = Just fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = Just fl}) "<file>")+ "key file"+ , Option+ []+ ["ech-config"]+ (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "<file>")+ "ECH config file"+ , Option+ []+ ["trace-key"]+ (NoArg (\o -> o{optTraceKey = True}))+ "Trace transcript hash"+ , Option+ ['4']+ []+ (NoArg (\o -> o{optIPv4Only = True, optIPv6Only = False}))+ "IPv4 only"+ , Option+ ['6']+ []+ (NoArg (\o -> o{optIPv6Only = True, optIPv4Only = False}))+ "IPv6 only"+ , Option+ ['t']+ ["trusted-anchor"]+ (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "<file>")+ "trusted anchor file" ] showUsageAndExit :: String -> IO a showUsageAndExit msg = do putStrLn msg putStrLn $ usageInfo usage options- putStrLn $ " <groups> = " ++ (intercalate "," (map fst namedGroups))+ putStrLn $ " <groups> = " ++ intercalate "," (map fst namedGroups) exitFailure clientOpts :: [String] -> IO (Options, [String])@@ -129,14 +191,24 @@ [] -> showUsageAndExit usage _ : [] -> showUsageAndExit usage h : p : [] -> return (h, p, ["/"])- h : p : ps -> return (h, p, C8.pack <$> ps)+ h : p : ps -> return (h, p, C8.pack <$> NE.fromList ps) when (null optGroups) $ do putStrLn "Error: unsupported groups" exitFailure- ref <- newIORef Nothing+ let onCertReq = \_ -> case optCertFile of+ Just certFile -> case optKeyFile of+ Just keyFile -> do+ Right (!cc, !priv) <- credentialLoadX509 certFile keyFile+ return $ Just (cc, priv)+ _ -> return Nothing+ _ -> return Nothing+ ref <- newIORef [] let debug | optDebugLog = putStrLn | otherwise = \_ -> return ()+ traceKey+ | optTraceKey = putStrLn+ | otherwise = \_ -> return () showContent | optShow = C8.putStr | otherwise = \_ -> return ()@@ -144,23 +216,45 @@ Aux { auxAuthority = host , auxPort = port- , auxDebug = debug+ , auxDebugPrint = debug , auxShow = showContent , auxReadResumptionData = readIORef ref }- mstore <-- if optValidate then Just <$> getSystemCertificateStore else return Nothing- let keyLog = getLogger optKeyLogFile- groups- | optRetry = FFDHE8192 : optGroups- | otherwise = optGroups- cparams = getClientParams optVersions host port groups (smIORef ref) mstore keyLog- runClient opts cparams aux paths+ mstore <- case optTrustedAnchor of+ Nothing ->+ if optValidate then Just <$> getSystemCertificateStore else return Nothing+ Just file -> do+ mstore' <- readCertificateStore file+ when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"+ return mstore'+ echConfList <- case optECHConfigFile of+ Nothing -> return []+ Just ecnff ->+ loadECHConfigList ecnff `E.catch` \(E.SomeException _) -> do+ putStrLn $ ecnff ++ " is broken"+ exitFailure+ let cparams =+ getClientParams+ opts+ host+ port+ (smIORef ref)+ mstore+ onCertReq+ echConfList+ debug+ traceKey+ client+ | optALPN == "dot" = clientDNS+ | otherwise = clientHTTP11+ makeCipherShowPretty+ runClient opts client cparams aux paths -runClient :: Options -> ClientParams -> Aux -> [ByteString] -> IO ()-runClient opts@Options{..} cparams aux@Aux{..} paths = do- auxDebug "------------------------"- (info1, msd) <- runTLS cparams aux $ \ctx -> do+runClient+ :: Options -> Cli -> ClientParams -> Aux -> NonEmpty ByteString -> IO ()+runClient opts@Options{..} client cparams aux@Aux{..} paths = do+ auxDebugPrint "------------------------"+ (info1, msd) <- runTLS opts cparams aux $ \ctx -> do i1 <- getInfo ctx when optDebugLog $ printHandshakeInfo i1 client aux paths ctx@@ -171,7 +265,7 @@ if isResumptionPossible msd then do let cparams2 = modifyClientParams cparams msd False- info2 <- runClient2 opts cparams2 aux paths+ info2 <- runClient2 opts client cparams2 aux paths if infoVersion info1 == TLS12 then do if infoTLS12Resumption info2@@ -196,7 +290,7 @@ if is0RTTPossible info1 msd then do let cparams2 = modifyClientParams cparams msd True- info2 <- runClient2 opts cparams2 aux paths+ info2 <- runClient2 opts client cparams2 aux paths if infoTLS13HandshakeMode info2 == Just RTT0 then do putStrLn "Result: (Z) 0-RTT ... OK"@@ -217,22 +311,22 @@ exitFailure | otherwise -> do putStrLn "Result: (H) handshake ... OK"- let malpn = (snd <$> msd) >>= sessionALPN- when (malpn == Just "http/1.1") $+ when (optALPN == "http/1.1") $ putStrLn "Result: (1) HTTP/1.1 transaction ... OK" exitSuccess runClient2 :: Options+ -> Cli -> ClientParams -> Aux- -> [ByteString]+ -> NonEmpty ByteString -> IO Information-runClient2 Options{..} cparams aux@Aux{..} paths = do+runClient2 opts@Options{..} client cparams aux@Aux{..} paths = do threadDelay 100000- auxDebug "<<<< next connection >>>>"- auxDebug "------------------------"- runTLS cparams aux $ \ctx -> do+ auxDebugPrint "<<<< next connection >>>>"+ auxDebugPrint "------------------------"+ runTLS opts cparams aux $ \ctx -> do if opt0RTT then do void $ client aux paths ctx@@ -246,81 +340,126 @@ return i runTLS- :: ClientParams+ :: Options+ -> ClientParams -> Aux -> (Context -> IO a) -> IO a-runTLS cparams Aux{..} action =- runTCPClient auxAuthority auxPort $ \sock -> do- E.bracket (contextNew sock cparams) bye $ \ctx -> do- handshake ctx- action ctx+runTLS Options{..} cparams Aux{..} action =+ runTCPClientWithSettings settings auxAuthority auxPort $ \sock -> do+ ctx <- contextNew sock cparams+ when optDebugLog $+ contextHookSetLogging+ ctx+ defaultLogging+ { loggingPacketSent = putStrLn . (">> " ++)+ , loggingPacketRecv = putStrLn . ("<< " ++)+ -- , loggingIOSent = \bs -> putStrLn $ "}} " ++ showBytesHex bs+ -- , loggingIORecv = \hd bs -> putStrLn $ "{{ " ++ show hd ++ " " ++ showBytesHex bs+ }+ handshake ctx+ r <- action ctx+ bye ctx+ return r+ where+ select addrs+ | optIPv4Only = case NE.filter (\ai -> addrFamily ai == AF_INET) addrs of+ [] -> error "IPv4 address is not available"+ ai : _ -> ai+ | optIPv6Only = case NE.filter (\ai -> addrFamily ai == AF_INET6) addrs of+ [] -> error "IPv6 address is not available"+ ai : _ -> ai+ | otherwise = NE.head addrs+ settings =+ defaultSettings+ { settingsSelectAddrInfo = select+ } modifyClientParams- :: ClientParams -> Maybe (SessionID, SessionData) -> Bool -> ClientParams-modifyClientParams cparams wantResume early =+ :: ClientParams -> [(SessionID, SessionData)] -> Bool -> ClientParams+modifyClientParams cparams ts early = cparams- { clientWantSessionResume = wantResume+ { clientWantSessionResumeList = ts , clientUseEarlyData = early } getClientParams- :: [Version]+ :: Options -> HostName -> ServiceName- -> [Group] -> SessionManager -> Maybe CertificateStore+ -> OnCertificateRequest+ -> ECHConfigList -> (String -> IO ())+ -> (String -> IO ()) -> ClientParams-getClientParams vers serverName port groups sm mstore keyLog =+getClientParams Options{..} serverName port sm mstore onCertReq echConfList printError traceKey = (defaultParamsClient serverName (C8.pack port)) { clientSupported = supported , clientUseServerNameIndication = True , clientShared = shared , clientHooks = hooks , clientDebug = debug+ , clientUseECH = not (null echConfList) } where+ groups+ | optRetry = FFDHE8192 : optGroups+ | otherwise = optGroups shared =- def+ defaultShared { sharedSessionManager = sm- , sharedCAStore = case mstore of- Just store -> store- Nothing -> mempty+ , sharedCAStore = fromMaybe mempty mstore , sharedValidationCache = validateCache+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 8192+ }+ , sharedECHConfigList = echConfList } supported =- def- { supportedVersions = vers+ defaultSupported+ { supportedVersions = optVersions , supportedGroups = groups } hooks =- def- { onSuggestALPN = return $ Just ["http/1.1"]+ defaultClientHooks+ { onSuggestALPN = return $ Just [C8.pack optALPN]+ , onCertificateRequest = onCertReq } validateCache- | isJust mstore = def+ | isJust mstore = sharedValidationCache defaultShared | otherwise = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) debug =- def- { debugKeyLogger = keyLog+ defaultDebugParams+ { debugKeyLogger = getLogger optKeyLogFile+ , debugError = printError+ , debugTraceKey = traceKey } -smIORef :: IORef (Maybe (SessionID, SessionData)) -> SessionManager+smIORef :: IORef [(SessionID, SessionData)] -> SessionManager smIORef ref = noSessionManager- { sessionEstablish = \sid sdata -> writeIORef ref (Just (sid, sdata)) >> return Nothing+ { sessionEstablish = \sid sdata ->+ modifyIORef' ref (\xs -> (sid, sdata) : xs)+ >> printTicket sid sdata+ >> return Nothing } -isResumptionPossible :: Maybe (SessionID, SessionData) -> Bool-isResumptionPossible = isJust+printTicket :: SessionID -> SessionData -> IO ()+printTicket sid sdata = do+ C8.putStr $ "Ticket: " <> C8.take 16 (BS16.encode sid) <> "..., "+ putStrLn $ "0-RTT: " <> if sessionMaxEarlyDataSize sdata > 0 then "OK" else "NG" -is0RTTPossible :: Information -> Maybe (SessionID, SessionData) -> Bool-is0RTTPossible _ Nothing = False-is0RTTPossible info (Just (_, sd)) =+isResumptionPossible :: [(SessionID, SessionData)] -> Bool+isResumptionPossible = not . null++is0RTTPossible :: Information -> [(SessionID, SessionData)] -> Bool+is0RTTPossible _ [] = False+is0RTTPossible info xs = infoVersion info == TLS13- && sessionMaxEarlyDataSize sd > 0+ && any (\(_, sd) -> sessionMaxEarlyDataSize sd > 0) xs
util/tls-server.hs view
@@ -1,20 +1,25 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-} module Main where -import Data.Default.Class (def)+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) import System.Exit import System.IO-import qualified UnliftIO.Exception as E+import System.X509 import Common import Imports@@ -22,11 +27,18 @@ data Options = Options { optDebugLog :: Bool+ , optClientAuth :: Bool , optShow :: Bool , optKeyLogFile :: Maybe FilePath- , optGroups :: [Group]+ , optTrustedAnchor :: Maybe FilePath+ , optGroups :: Maybe [Group] , optCertFile :: FilePath , optKeyFile :: FilePath+ , optECHConfigFile :: Maybe FilePath+ , optECHKeyFile :: Maybe FilePath+ , optTraceKey :: Bool+ , optUseWeakCiphers :: Bool+ , optServerName :: Maybe HostName } deriving (Show) @@ -34,17 +46,28 @@ defaultOptions = Options { optDebugLog = False+ , optClientAuth = False , optShow = False , optKeyLogFile = Nothing- , -- excluding FFDHE8192 for retry- optGroups = [X25519, X448, P256, P521]+ , optTrustedAnchor = Nothing+ , optGroups = Nothing , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem"+ , optECHConfigFile = Nothing+ , optECHKeyFile = Nothing+ , optTraceKey = False+ , optUseWeakCiphers = False+ , optServerName = Nothing } options :: [OptDescr (Options -> Options)] options = [ Option+ ['a']+ ["client-auth"]+ (NoArg (\o -> o{optClientAuth = True}))+ "require client authentication"+ , Option ['d'] ["debug"] (NoArg (\o -> o{optDebugLog = True}))@@ -62,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']@@ -74,10 +97,40 @@ ["key"] (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>") "key file"+ , Option+ ['t']+ ["trusted-anchor"]+ (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "<file>")+ "trusted anchor file"+ , Option+ []+ ["ech-config"]+ (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "<file>")+ "ECH config file"+ , Option+ []+ ["ech-key"]+ (ReqArg (\fl o -> o{optECHKeyFile = Just fl}) "<file>")+ "ECH key file"+ , Option+ []+ ["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-usage = "Usage: server [OPTION] addr port"+usage = "Usage: tls-server [OPTION] addr port" showUsageAndExit :: String -> IO a showUsageAndExit msg = do@@ -99,62 +152,269 @@ (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+ when (null groups) $ do putStrLn "Error: unsupported groups" exitFailure smgr <- newSessionManager Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile+ mstore <- do+ mstore' <- case optTrustedAnchor of+ Nothing -> Just <$> getSystemCertificateStore+ Just file -> readCertificateStore file+ when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"+ return mstore'+ ech <- case optECHKeyFile of+ Nothing -> case optECHConfigFile of+ Nothing -> return ([], [])+ Just _ -> showUsageAndExit "must specify ECH key file, too"+ Just ekeyf -> case optECHConfigFile of+ Nothing -> showUsageAndExit "must specify ECH config file, too"+ Just ecnff -> do+ ekey <- loadECHSecretKeys [ekeyf]+ ecnf <- loadECHConfigList ecnff+ return (ekey, ecnf) let keyLog = getLogger optKeyLogFile+ printError+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ traceKey+ | optTraceKey = putStrLn+ | otherwise = \_ -> return () creds = Credentials [cred]+ makeCipherShowPretty runTCPServer (Just host) port $ \sock -> do- let sparams = getServerParams creds optGroups smgr keyLog- E.bracket (contextNew sock sparams) bye $ \ctx -> do- handshake ctx- when (optDebugLog || optShow) $ putStrLn "------------------------"- when optDebugLog $- getInfo ctx >>= printHandshakeInfo- server ctx optShow+ let sparams =+ getServerParams+ creds+ optUseWeakCiphers+ groups+ smgr+ keyLog+ optClientAuth+ mstore+ ech+ printError+ traceKey+ optServerName+ ctx <- contextNew sock sparams+ when optDebugLog $+ contextHookSetLogging+ ctx+ defaultLogging+ { loggingPacketSent = putStrLn . ("<< " ++)+ , loggingPacketRecv = putStrLn . (">> " ++)+ -- , loggingIOSent = \bs -> putStrLn $ "{{ " ++ showBytesHex bs+ -- , loggingIORecv = \hd bs -> putStrLn $ "}} " ++ show hd ++ " " ++ showBytesHex bs+ }+ when (optDebugLog || optShow) $ putStrLn "------------------------"+ handshake ctx+ when optDebugLog $+ getInfo ctx >>= printHandshakeInfo+ server ctx optShow+ bye ctx getServerParams :: Credentials+ -> Bool -> [Group] -> SessionManager -> (String -> IO ())+ -> Bool+ -> Maybe CertificateStore+ -> ([(Word8, ByteString)], ECHConfigList)+ -> (String -> IO ())+ -> (String -> IO ())+ -> Maybe HostName -> ServerParams-getServerParams creds groups sm keyLog =- def+getServerParams creds weak groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey mname =+ defaultParamsServer { serverSupported = supported , serverShared = shared , serverHooks = hooks , serverDebug = debug , serverEarlyDataSize = 2048+ , serverWantClientCert = clientAuth+ , serverECHKey = ekey+ , serverDHEParams = if weak then Just ffdhe2048 else Nothing } where shared =- def+ defaultShared { sharedCredentials = creds , sharedSessionManager = sm+ , sharedCAStore = case mstore of+ Just store -> store+ Nothing -> sharedCAStore defaultShared+ , sharedECHConfigList = ecnf+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 16384+ } } supported =- def- { supportedGroups = groups+ defaultSupported+ { supportedCiphers = ciphers+ , supportedGroups = groups+ , supportedExtendedMainSecret =+ if weak then AllowEMS else supportedExtendedMainSecret defaultSupported+ , supportedClientInitiatedRenegotiation =+ weak || supportedClientInitiatedRenegotiation defaultSupported }- hooks = def{onALPNClientSuggest = Just chooseALPN}- debug = def{debugKeyLogger = keyLog}+ ciphers+ | weak = ciphersuite_default ++ ciphersForFuzzer+ | otherwise = ciphersuite_default+ hooks =+ defaultServerHooks+ { onALPNClientSuggest = Just $ chooseALPN weak+ , onClientCertificate = case mstore of+ Nothing -> onClientCertificate defaultServerHooks+ Just _+ | weak -> acceptEmptyCertificate+ | otherwise ->+ validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+ , onServerNameIndication = checkServerName mname+ }+ debug =+ defaultDebugParams+ { debugKeyLogger = keyLog+ , 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 return $ noSessionManager- { sessionResume = \key -> M.lookup key <$> readIORef ref- , sessionResumeOnlyOnce = \key -> M.lookup key <$> readIORef ref- , sessionEstablish = \key val -> atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing)- , sessionInvalidate = \key -> atomicModifyIORef' ref $ \m -> (M.delete key m, ())- , sessionUseTicket = False+ { sessionResume = \key -> do+ M.lookup key <$> readIORef ref+ , sessionResumeOnlyOnce = \key -> do+ M.lookup key <$> readIORef ref+ , -- 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 = True }