tls 1.6.0 → 2.4.3
raw patch · 122 files changed
Files
- Benchmarks/Benchmarks.hs +115/−92
- CHANGELOG.md +249/−1
- Network/TLS.hs +309/−132
- Network/TLS/Backend.hs +39/−71
- Network/TLS/Cap.hs +0/−19
- Network/TLS/Cipher.hs +57/−119
- Network/TLS/Compression.hs +20/−25
- Network/TLS/Context.hs +241/−182
- Network/TLS/Context/Internal.hs +394/−202
- Network/TLS/Core.hs +416/−239
- Network/TLS/Credentials.hs +93/−85
- Network/TLS/Crypto.hs +279/−208
- Network/TLS/Crypto/DH.hs +32/−31
- Network/TLS/Crypto/IES.hs +426/−164
- Network/TLS/Crypto/Types.hs +129/−9
- Network/TLS/ErrT.hs +8/−14
- Network/TLS/Error.hs +198/−0
- Network/TLS/Extension.hs +1175/−701
- Network/TLS/Extension.hs-boot +22/−0
- Network/TLS/Extra.hs +5/−12
- Network/TLS/Extra/Cipher.hs +808/−1156
- Network/TLS/Extra/CipherCBC.hs +201/−0
- Network/TLS/Extra/FFDHE.hs +35/−25
- Network/TLS/Handshake.hs +21/−26
- Network/TLS/Handshake/Certificate.hs +46/−31
- Network/TLS/Handshake/Client.hs +177/−1099
- Network/TLS/Handshake/Client/ClientHello.hs +610/−0
- Network/TLS/Handshake/Client/Common.hs +363/−0
- Network/TLS/Handshake/Client/ServerHello.hs +306/−0
- Network/TLS/Handshake/Client/TLS12.hs +288/−0
- Network/TLS/Handshake/Client/TLS13.hs +425/−0
- Network/TLS/Handshake/Common.hs +342/−161
- Network/TLS/Handshake/Common13.hs +472/−308
- Network/TLS/Handshake/Control.hs +19/−25
- Network/TLS/Handshake/Key.hs +77/−73
- Network/TLS/Handshake/Process.hs +0/−146
- Network/TLS/Handshake/Random.hs +42/−43
- Network/TLS/Handshake/Server.hs +88/−1213
- Network/TLS/Handshake/Server/ClientHello.hs +305/−0
- Network/TLS/Handshake/Server/ClientHello12.hs +235/−0
- Network/TLS/Handshake/Server/ClientHello13.hs +212/−0
- Network/TLS/Handshake/Server/Common.hs +207/−0
- Network/TLS/Handshake/Server/ServerHello12.hs +325/−0
- Network/TLS/Handshake/Server/ServerHello13.hs +367/−0
- Network/TLS/Handshake/Server/TLS12.hs +216/−0
- Network/TLS/Handshake/Server/TLS13.hs +387/−0
- Network/TLS/Handshake/Signature.hs +189/−184
- Network/TLS/Handshake/State.hs +429/−379
- Network/TLS/Handshake/State13.hs +98/−119
- Network/TLS/Handshake/TranscriptHash.hs +131/−0
- Network/TLS/HashAndSignature.hs +181/−0
- Network/TLS/Hooks.hs +33/−36
- Network/TLS/IO.hs +151/−116
- Network/TLS/IO/Decode.hs +109/−0
- Network/TLS/IO/Encode.hs +148/−0
- Network/TLS/Imports.hs +19/−45
- Network/TLS/Internal.hs +32/−23
- Network/TLS/KeySchedule.hs +27/−27
- Network/TLS/MAC.hs +58/−56
- Network/TLS/Measurement.hs +24/−26
- Network/TLS/Packet.hs +461/−496
- Network/TLS/Packet13.hs +164/−127
- Network/TLS/Parameters.hs +899/−636
- Network/TLS/PostHandshake.hs +24/−30
- Network/TLS/QUIC.hs +144/−141
- Network/TLS/RNG.hs +16/−15
- Network/TLS/Receiving.hs +0/−102
- Network/TLS/Record.hs +32/−38
- Network/TLS/Record/Decrypt.hs +207/−0
- Network/TLS/Record/Disengage.hs +0/−201
- Network/TLS/Record/Encrypt.hs +131/−0
- Network/TLS/Record/Engage.hs +0/−146
- Network/TLS/Record/Layer.hs +45/−44
- Network/TLS/Record/Reading.hs +0/−118
- Network/TLS/Record/Recv.hs +112/−0
- Network/TLS/Record/Send.hs +61/−0
- Network/TLS/Record/State.hs +104/−97
- Network/TLS/Record/Types.hs +46/−56
- Network/TLS/Record/Writing.hs +0/−69
- Network/TLS/Sending.hs +0/−121
- Network/TLS/Session.hs +27/−26
- Network/TLS/State.hs +263/−185
- Network/TLS/Struct.hs +402/−569
- Network/TLS/Struct13.hs +61/−82
- Network/TLS/Types.hs +50/−116
- Network/TLS/Types/Cipher.hs +130/−0
- Network/TLS/Types/Secret.hs +62/−0
- Network/TLS/Types/Session.hs +73/−0
- Network/TLS/Types/Version.hs +40/−0
- Network/TLS/Util.hs +79/−66
- Network/TLS/Util/ASN1.hs +21/−26
- Network/TLS/Util/Serialization.hs +6/−6
- Network/TLS/Wire.hs +76/−73
- Network/TLS/X509.hs +63/−47
- Setup.hs +1/−0
- Tests/Certificate.hs +0/−146
- Tests/Ciphers.hs +0/−50
- Tests/Connection.hs +0/−426
- Tests/Marshalling.hs +0/−186
- Tests/PipeChan.hs +0/−70
- Tests/PubKey.hs +0/−133
- Tests/Tests.hs +0/−1054
- test/API.hs +22/−0
- test/Arbitrary.hs +452/−0
- test/Certificate.hs +161/−0
- test/CiphersSpec.hs +76/−0
- test/ECHSpec.hs +446/−0
- test/EncodeSpec.hs +39/−0
- test/HandshakeSpec.hs +1088/−0
- test/PipeChan.hs +85/−0
- test/PubKey.hs +123/−0
- test/Run.hs +394/−0
- test/Session.hs +92/−0
- test/Spec.hs +1/−0
- test/ThreadSpec.hs +46/−0
- tls.cabal +273/−182
- util/Client.hs +61/−0
- util/Common.hs +133/−0
- util/Imports.hs +17/−0
- util/Server.hs +92/−0
- util/tls-client.hs +465/−0
- util/tls-server.hs +270/−0
Benchmarks/Benchmarks.hs view
@@ -1,88 +1,109 @@ {-# LANGUAGE BangPatterns #-}+ module Main where -import Connection import Certificate-import PubKey-import Gauge.Main import Control.Concurrent.Chan-import Network.TLS-import Network.TLS.Extra.Cipher+import Data.Default (def)+import Data.IORef import Data.X509 import Data.X509.Validation-import Data.Default.Class-import Data.IORef+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)+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 }- , 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)+ 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- }- }+ , clientShared =+ def+ { sharedValidationCache =+ ValidationCache+ { cacheAdd = \_ _ _ -> return ()+ , cacheQuery = \_ _ _ -> return ValidationCachePass+ }+ } }- supported = def { supportedCiphers = [cipher]- , supportedVersions = [connectVer]- , supportedGroups = [X25519, FFDHE2048]- }- (pubKey, privKey) = getGlobalRSAPair+ 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+ :: (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+ :: (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+ 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+ :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d -benchResumption :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark+benchResumption+ :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption params !d name = env initializeSession runResumption where initializeSession = do@@ -99,7 +120,8 @@ params2 <- readIORef paramsRef runTLSPipeSimple params2 d -benchResumption13 :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark+benchResumption13+ :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption13 params !d name = env initializeSession runResumption where initializeSession = do@@ -124,41 +146,42 @@ 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 SSL3 blockCipher) small "SSL3-256 bytes"- , benchConnection (getParams TLS10 blockCipher) small "TLS10-256 bytes"- , benchConnection (getParams TLS11 blockCipher) small "TLS11-256 bytes"- , benchConnection (getParams TLS12 blockCipher) small "TLS12-256 bytes"- ]- , bgroup "resumption"- [ benchResumption (getParams SSL3 blockCipher) small "SSL3-256 bytes"- , benchResumption (getParams TLS10 blockCipher) small "TLS10-256 bytes"- , benchResumption (getParams TLS11 blockCipher) small "TLS11-256 bytes"- , 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_AES128GCM_SHA256- , cipher_DHE_RSA_AES256GCM_SHA384- , cipher_DHE_RSA_CHACHA20POLY1305_SHA256- , cipher_DHE_RSA_AES128CCM_SHA256- , cipher_DHE_RSA_AES128CCM8_SHA256- , cipher_ECDHE_RSA_AES128GCM_SHA256- , cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256- ]- , benchCiphers "TLS13" TLS13 large- [ cipher_TLS13_AES128GCM_SHA256- , cipher_TLS13_AES256GCM_SHA384- , cipher_TLS13_CHACHA20POLY1305_SHA256- , cipher_TLS13_AES128CCM_SHA256- , cipher_TLS13_AES128CCM8_SHA256+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,251 @@+# Change log for "tls"++## Version 2.4.3++* A server checks clientAuth of ExtendedKeyUsage in a client+ certificate on client authentication.++## Version 2.4.2++* The `Network.TLS.Extra.CipherCBC` module is added.+ [#526](https://github.com/haskell-tls/hs-tls/pull/526)++## Version 2.4.1++* Ensure same `supported_groups` before/after HRR.+* New `clientWantTicket` parameter makes it possible to opt-out of soliciting+ session tickets from servers.++## Version 2.4.0++* Identical to v2.3.1 but major version up as v2.3.1 breaks "quic".++## Version 2.3.1 (deprecated)++* Using ScrubbedBytes for secrets.+* Key echange with ML-KEM.+ [#517](https://github.com/haskell-tls/hs-tls/pull/517)+* Expose get certificate chain function+ [#520](https://github.com/haskell-tls/hs-tls/pull/520)++## Version 2.3.0++* Using "ram" instead of "memory".++## Version 2.2.2++* A new architecture to calculate receiver's transcript hash with wire+ format.+ [#515](https://github.com/haskell-tls/hs-tls/pull/515)+* Enabling compressed certificate on the client side again.++## Version 2.2.1++* Disabling compressed certificate on the client side.+ [#514](https://github.com/haskell-tls/hs-tls/issues/514)++## Version 2.2.0++* Using crypton-asn1-* and time-hourglass.+ [#512](https://github.com/haskell-tls/hs-tls/pull/512)+* Major version up due to re-exports.++## Version 2.1.14++* Supporting P384 and P521 curves.+ [#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`.+ So, users don't have to override this value anymore by exporting+ `Network.TLS.Extra.Cipher`.+ [#471](https://github.com/haskell-tls/hs-tls/pull/471)+* `ciphersuite_default` is the same as `ciphersuite_strong`.+ So, the duplicated definition is removed.+* Add missing modules for util/tls-client and util/tls-server.++## Version 2.0.5++* Fixing handshake13_0rtt_fallback+* Client checks if the group of PSK is contained in Supported_Groups.+* HRR is not allowed for 0-RTT.++## Version 2.0.4++* More fix for 0-RTT when application data is available while receiving CF.+* New util/tls-client and util/tls-server.++## Version 2.0.3++* Fixing a bug where `timeout` in `bye` does not work.+* util/client -> util/tls-client+* util/server -> util/tls-server++## Version 2.0.2++* Client checks sessionMaxEarlyDataSize to decide 0-RTT+* Client checks the resumption cipher properly.++## Version 2.0.1++* Fix a leak of pending data to be sent.++## Version 2.0.0++* `tls` now only supports TLS 1.2 and TLS 1.3 with safe cipher suites.+* Security: BREAKING CHANGE: TLS 1.0 and TLS 1.1 are removed.+* Security: BREAKING CHANGE: all CBC cipher suite are removed.+* Security: BREAKING CHANGE: RC4 and 3DES are removed.+* Security: BREAKING CHANGE: DSS(digital signature standard) is removed.+* Security: BREAKING CHANGE: TLS 1.2 servers require+ EMS(extended main secret) by default.+ `supportedExtendedMasterSec` is renamed to+ `supportedExtendedMainSecret`.+* BREAKING CHANGE: the package is now complied with `Strict` and `StrictData`.+* BREAKING CHANGE: Many data structures are re-defined with+ `PatternSynonyms` for extensibility.+* BREAKING CHANGE: the structure of `SessionManager` is changed+ to support session tickets.+* API: BREAKING CHANGE: `sendData` can send early data (0-RTT).+ `clientEarlyData` is removed.+ To send early data via `sendData`, set `clientUseEarlyData` to `True`.+ [#466](https://github.com/haskell-tls/hs-tls/issues/466)+* API: `handshake` can receive an alert of client authentication failure+ for TLS 1.3.+ [#463](https://github.com/haskell-tls/hs-tls/pull/463)+* API: `bye` can receive NewSessionTicket for TLS 1.3.+* Channel binding: `getFinished` and `getPeerFinished` are deprecated.+ Use `getTLSUnique` instead.+ [#462](https://github.com/haskell-tls/hs-tls/pull/462)+* Channel binding: `getTLSExporter` and `getTLSServerEndPoint` are provided.+ [#462](https://github.com/haskell-tls/hs-tls/pull/462)+* Refactoring: the monolithic `handshake` is divided to follow+ the diagram of TLS 1.2 and 1.3 for readability.+* Refactoring: test cases are refactored for maintenability+ and readablity. `hspec` is used instead of `tasty`.+* Code format: `fourmolu` is used as an official formatter.+* Catching up RFC8446bis-09.+ [#467](https://github.com/haskell-tls/hs-tls/issues/467)++## Version 1.9.0++* BREAKING CHANGE: The type of the `Error_Protocol` constructor of `TLSError` has changed.+ The "warning" case has been split off into a new `Error_Protocol_Warning` constructor.+ [#460](https://github.com/haskell-tls/hs-tls/pull/460)++## Version 1.8.0++* BREAKING CHANGE: Remove `Exception` instance for `TLSError`.+ The library now throws `TLSException` only.+ If you need to change your code, please refer to+ [this example](https://github.com/snoyberg/http-client/commit/73d1a4eb451c089878ba95e96371d0b18287ffb8) first.+ [#457](https://github.com/haskell-tls/hs-tls/pull/457)++## Version 1.7.1++* NOP on UserCanceled event+ [#454](https://github.com/haskell-tls/hs-tls/pull/454)++## Version 1.7.0++* Major version up because "crypton" is used instead of "cryptonite"+ ## Version 1.6.0 - Major version up because of disabling SSL3@@ -124,7 +372,7 @@ API CHANGES: - `SessionManager` implementations need to provide a `sessionResumeOnlyOnce`- function to accomodate resumption scenarios with 0-RTT data. The function is+ function to accommodate resumption scenarios with 0-RTT data. The function is called only on the server side. - Data type `SessionData` is extended with four new fields for TLS version 1.3. `SessionManager` implementations that serializes/deserializes `SessionData`
Network/TLS.hs view
@@ -1,195 +1,363 @@-{-# LANGUAGE CPP #-} -- |--- Module : Network.TLS--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Native Haskell TLS and SSL protocol implementation for server and--- client.+-- Native Haskell TLS protocol implementation for servers and+-- clients. -- -- This provides a high-level implementation of a sensitive security -- protocol, eliminating a common set of security issues through the -- use of the advanced type system, high level constructions and -- common Haskell features. ----- Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3+-- 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. ----- Some debug tools linked with tls, are available through the--- http://hackage.haskell.org/package/tls-debug/.--module Network.TLS- (+-- The typical usage is:+--+-- > socket <- ...+-- > ctx <- contextNew socket <params>+-- > handshake ctx+-- > ... (using recvData and sendData)+-- > bye+module Network.TLS ( -- * Basic APIs- Context- , contextNew- , handshake- , sendData- , recvData- , bye+ Context,+ contextNew,+ handshake,+ sendData,+ recvData,+ bye, + -- * Exceptions+ -- $exceptions+ -- * Backend abstraction- , HasBackend(..)- , Backend(..)+ HasBackend (..),+ Backend (..), -- * Parameters+ -- intentionally hide the internal methods even haddock warns.- , TLSParams- , ClientParams(..)- , defaultParamsClient- , ServerParams(..)+ TLSParams,++ -- ** Client parameters+ ClientParams,+ defaultParamsClient,+ 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(..)- -- ** Hooks- , ClientHooks(..)- , OnCertificateRequest- , OnServerCertificate- , ServerHooks(..)- , Measurement(..)+ Shared,+ defaultShared,+ sharedCredentials,+ sharedSessionManager,+ sharedCAStore,+ sharedValidationCache,+ sharedHelloExtensions,+ sharedECHConfigList,+ sharedLimit,++ -- ** Client hooks+ ClientHooks,+ defaultClientHooks,+ OnCertificateRequest,+ onCertificateRequest,+ OnServerCertificate,+ 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,+ limitRecordSize,+ -- * Shared parameters+ -- ** Credentials- , Credentials(..)- , Credential- , credentialLoadX509- , credentialLoadX509FromMemory- , credentialLoadX509Chain- , credentialLoadX509ChainFromMemory+ Credentials (..),+ Credential,+ credentialLoadX509,+ credentialLoadX509FromMemory,+ credentialLoadX509Chain,+ credentialLoadX509ChainFromMemory,+ -- ** Session manager- , SessionManager(..)- , noSessionManager- , SessionID- , SessionData(..)- , SessionFlag(..)- , TLS13TicketInfo+ SessionManager,+ noSessionManager,+ sessionResume,+ sessionResumeOnlyOnce,+ sessionEstablish,+ sessionInvalidate,+ sessionUseTicket,+ SessionID,+ SessionIDorTicket,+ Ticket,++ -- ** Session data+ SessionData,+ sessionVersion,+ sessionCipher,+ sessionCompression,+ sessionClientSNI,+ sessionSecret,+ sessionGroup,+ sessionTicketInfo,+ sessionALPN,+ sessionMaxEarlyDataSize,+ sessionFlags,+ SessionFlag (..),+ TLS13TicketInfo,+ is0RTTPossible,+ -- ** Validation Cache- , ValidationCache(..)- , ValidationCacheQueryCallback- , ValidationCacheAddCallback- , ValidationCacheResult(..)- , exceptionValidationCache+ ValidationCache (..),+ defaultValidationCache,+ ValidationCacheQueryCallback,+ ValidationCacheAddCallback,+ ValidationCacheResult (..),+ exceptionValidationCache, -- * Types+ -- ** For 'Supported'- , Version(..)- , Compression(..)- , nullCompression- , HashAndSignatureAlgorithm- , HashAlgorithm(..)- , SignatureAlgorithm(..)- , Group(..)- , EMSMode(..)+ Version (..),+ Compression (..),+ nullCompression,+ HashAndSignatureAlgorithm,+ supportedSignatureSchemes,+ HashAlgorithm (..),+ SignatureAlgorithm (..),+ Group (..),+ supportedNamedGroups,+ EMSMode (..),+ -- ** For parameters and hooks- , DHParams- , DHPublic- , GroupUsage(..)- , CertificateUsage(..)- , CertificateRejectReason(..)- , CertificateType(..)- , HostName- , MaxFragmentEnum(..)+ DHParams,+ DHPublic,+ GroupUsage (..),+ CertificateUsage (..),+ CertificateRejectReason (..),+ CertificateType (..),+ CertificateChain (..),+ HostName,+ MaxFragmentEnum (..), -- * Advanced APIs+ -- ** Backend- , ctxConnection- , contextFlush- , contextClose+ ctxBackend,+ contextFlush,+ contextClose,+ -- ** Information gathering- , Information(..)- , contextGetInformation- , ClientRandom- , ServerRandom- , unClientRandom- , unServerRandom- , HandshakeMode13(..)- , getClientCertificateChain+ Information,+ contextGetInformation,+ infoVersion,+ infoCipher,+ infoCompression,+ infoMainSecret,+ infoExtendedMainSecret,+ infoClientRandom,+ infoServerRandom,+ infoSupportedGroup,+ infoTLS12Resumption,+ infoTLS13HandshakeMode,+ infoIsEarlyDataAccepted,+ infoIsECHAccepted,+ ClientRandom,+ ServerRandom,+ unClientRandom,+ unServerRandom,+ HandshakeMode13 (..),+ getClientCertificateChain,+ getServerCertificateChain,+ -- ** Negotiated- , getNegotiatedProtocol- , getClientSNI+ getNegotiatedProtocol,+ getClientSNI,+ -- ** Post-handshake actions- , updateKey- , KeyUpdateRequest(..)- , requestCertificate- , getFinished- , getPeerFinished+ updateKey,+ KeyUpdateRequest (..),+ requestCertificate,+ getTLSUnique,+ getTLSExporter,+ getTLSServerEndPoint,+ getFinished,+ getPeerFinished,+ -- ** Modifying hooks in context- , Hooks(..)- , contextModifyHooks- , Handshake- , contextHookSetHandshakeRecv- , Handshake13- , contextHookSetHandshake13Recv- , contextHookSetCertificateRecv- , Logging(..)- , Header(..)- , ProtocolType(..)- , contextHookSetLogging+ Hooks,+ defaultHooks,+ hookRecvHandshake,+ hookRecvHandshake13,+ hookRecvCertificates,+ hookLogging,+ contextModifyHooks,+ Handshake,+ contextHookSetHandshakeRecv,+ Handshake13,+ contextHookSetHandshake13Recv,+ contextHookSetCertificateRecv,+ Logging,+ defaultLogging,+ loggingPacketSent,+ loggingPacketRecv,+ loggingIOSent,+ loggingIORecv,+ Header (..),+ ProtocolType (..),+ contextHookSetLogging, -- * Errors and exceptions+ -- ** Errors- , TLSError(..)- , KxError(..)- , AlertDescription(..)+ TLSError (..),+ KxError (..),+ AlertDescription (..),+ -- ** Exceptions- , TLSException(..)+ TLSException (..), -- * Raw types+ -- ** Compressions class- , CompressionC(..)- , CompressionID+ CompressionC (..),+ CompressionID,+ -- ** Crypto Key- , PubKey(..)- , PrivKey(..)+ PubKey (..),+ PrivKey (..),+ -- ** Ciphers & Predefined ciphers- , module Network.TLS.Cipher+ module Network.TLS.Cipher, -- * Deprecated- , recvData'- , contextNewOnHandle-#ifdef INCLUDE_NETWORK- , contextNewOnSocket-#endif- , Bytes- , ValidationChecks(..)- , ValidationHooks(..)- ) where+ recvData',+ Bytes,+ ValidationChecks (..),+ ValidationHooks (..),+ clientUseMaxFragmentLength,+) where -import Network.TLS.Backend (Backend(..), HasBackend(..))+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 (CompressionC(..), Compression(..), nullCompression)+import Network.TLS.Compression (+ Compression (..),+ CompressionC (..),+ nullCompression,+ ) import Network.TLS.Context import Network.TLS.Core import Network.TLS.Credentials-import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..))-import Network.TLS.Handshake.State (HandshakeMode13(..))+import Network.TLS.Crypto (+ DHParams,+ DHPublic,+ 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 import qualified Network.TLS.State as S-import Network.TLS.Struct ( TLSError(..), TLSException(..)- , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..)- , Header(..), ProtocolType(..), CertificateType(..)- , AlertDescription(..)- , ClientRandom(..), ServerRandom(..)- , Handshake)-import Network.TLS.Struct13 ( Handshake13 )+import Network.TLS.Struct (+ AlertDescription (..),+ CertificateType (..),+ ClientRandom (..),+ Handshake,+ HashAlgorithm (..),+ HashAndSignatureAlgorithm,+ Header (..),+ ProtocolType (..),+ ServerRandom (..),+ SignatureAlgorithm (..),+ TLSError (..),+ TLSException (..),+ supportedSignatureSchemes,+ )+import Network.TLS.Struct13 (Handshake13) import Network.TLS.Types import Network.TLS.X509 -import Data.ByteString as B-import Data.X509 (PubKey(..), PrivKey(..))-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@@ -198,3 +366,12 @@ -- 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'.+-- In the common case where the chosen backend is socket, 'IOException'+-- may be thrown as well. This happens because the backend for sockets,+-- opaque to most modules in the @tls@ library, throws those exceptions.
Network/TLS/Backend.hs view
@@ -1,12 +1,4 @@-{-# LANGUAGE CPP #-}--- |--- Module : Network.TLS.Backend--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ A Backend represents a unified way to do IO on different+-- | A Backend represents a unified way to do IO on different -- types without burdening our calling API with multiple -- ways to initialize a new context. --@@ -15,32 +7,28 @@ -- * a way to write data -- * a way to close the stream -- * a way to flush the stream----module Network.TLS.Backend- ( HasBackend(..)- , Backend(..)- ) where+module Network.TLS.Backend (+ HasBackend (..),+ Backend (..),+) where -import Network.TLS.Imports import qualified Data.ByteString as B-import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose)--#ifdef INCLUDE_NETWORK-import qualified Network.Socket as Network (Socket, close)+import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network-#endif+import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) -#ifdef INCLUDE_HANS-import qualified Data.ByteString.Lazy as L-import qualified Hans.NetworkStack as Hans-#endif+import Network.TLS.Imports -- | Connection IO backend data Backend = Backend- { backendFlush :: IO () -- ^ Flush the connection sending buffer, if any.- , backendClose :: IO () -- ^ Close the connection.- , backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection.- , backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection.+ { backendFlush :: IO ()+ -- ^ Flush the connection sending buffer, if any.+ , backendClose :: IO ()+ -- ^ Close the connection.+ , backendSend :: ByteString -> IO ()+ -- ^ Send a bytestring through the connection.+ , backendRecv :: Int -> IO ByteString+ -- ^ Receive specified number of bytes from the connection. } class HasBackend a where@@ -51,54 +39,34 @@ initializeBackend _ = return () getBackend = id -#if defined(__GLASGOW_HASKELL__) && WINDOWS--- Socket recv and accept calls on Windows platform cannot be interrupted when compiled with -threaded.--- See https://ghc.haskell.org/trac/ghc/ticket/5797 for details.--- The following enables simple workaround-#define SOCKET_ACCEPT_RECV_WORKAROUND-#endif- safeRecv :: Network.Socket -> Int -> IO ByteString-#ifndef SOCKET_ACCEPT_RECV_WORKAROUND safeRecv = Network.recv-#else-safeRecv s buf = do- var <- newEmptyMVar- forkIO $ Network.recv s buf `E.catch` (\(_::IOException) -> return S8.empty) >>= putMVar var- takeMVar var-#endif -#ifdef INCLUDE_NETWORK instance HasBackend Network.Socket where initializeBackend _ = return ()- getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll- where recvAll n = B.concat <$> loop n- where loop 0 = return []- loop left = do- r <- safeRecv sock left- if B.null r- then return []- else (r:) <$> loop (left - B.length r)-#endif--#ifdef INCLUDE_HANS-instance HasBackend Hans.Socket where- initializeBackend _ = return ()- getBackend sock = Backend (return ()) (Hans.close sock) sendAll recvAll- where sendAll x = do- amt <- fromIntegral <$> Hans.sendBytes sock (L.fromStrict x)- if (amt == 0) || (amt == B.length x)- then return ()- else sendAll (B.drop amt x)- recvAll n = loop (fromIntegral n) L.empty- loop 0 acc = return (L.toStrict acc)- loop left acc = do- r <- Hans.recvBytes sock left- if L.null r- then loop 0 acc- else loop (left - L.length r) (acc `L.append` r)-#endif+ getBackend sock =+ Backend+ { backendFlush = return ()+ , backendClose = Network.close sock+ , backendSend = Network.sendAll sock+ , backendRecv = recvAll+ }+ where+ recvAll n = B.concat <$> loop n+ where+ loop 0 = return []+ loop left = do+ r <- safeRecv sock left+ if B.null r+ then return []+ else (r :) <$> loop (left - B.length r) 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/Cap.hs
@@ -1,19 +0,0 @@--- |--- Module : Network.TLS.Cap--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown-----module Network.TLS.Cap- ( hasHelloExtensions- , hasExplicitBlockIV- ) where--import Network.TLS.Types--hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool--hasHelloExtensions ver = ver >= SSL3-hasExplicitBlockIV ver = ver >= TLS11
Network/TLS/Cipher.hs view
@@ -1,146 +1,84 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-}--- |--- Module : Network.TLS.Cipher--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Cipher- ( CipherKeyExchangeType(..)- , Bulk(..)- , BulkFunctions(..)- , BulkDirection(..)- , BulkState(..)- , BulkStream(..)- , BulkBlock- , BulkAEAD- , bulkInit- , Hash(..)- , Cipher(..)- , CipherID- , cipherKeyBlockSize- , BulkKey- , BulkIV- , BulkNonce- , BulkAdditionalData- , cipherAllowedForVersion- , hasMAC- , hasRecordIV- ) where--import Crypto.Cipher.Types (AuthTag)-import Network.TLS.Types (CipherID, Version(..))-import Network.TLS.Crypto (Hash(..), hashDigestSize)+{-# OPTIONS_HADDOCK hide #-} -import qualified Data.ByteString as B+module Network.TLS.Cipher (+ CipherKeyExchangeType (..),+ Bulk (..),+ BulkFunctions (..),+ BulkDirection (..),+ BulkState (..),+ BulkStream (..),+ BulkBlock,+ BulkAEAD,+ bulkInit,+ Hash (..),+ Cipher (..),+ CipherID,+ cipherKeyBlockSize,+ BulkKey,+ BulkIV,+ BulkNonce,+ BulkAdditionalData,+ cipherAllowedForVersion,+ hasMAC,+ hasRecordIV,+ elemCipher,+ intersectCiphers,+ findCipher,+) where --- FIXME convert to newtype-type BulkKey = B.ByteString-type BulkIV = B.ByteString-type BulkNonce = B.ByteString-type BulkAdditionalData = B.ByteString+import Network.TLS.Crypto (Hash (..), hashDigestSize)+import Network.TLS.Imports+import Network.TLS.Types -data BulkState =- BulkStateStream BulkStream- | BulkStateBlock BulkBlock- | BulkStateAEAD BulkAEAD+data BulkState+ = BulkStateStream BulkStream+ | BulkStateBlock BulkBlock+ | BulkStateAEAD BulkAEAD | BulkStateUninitialized instance Show BulkState where- show (BulkStateStream _) = "BulkStateStream"- show (BulkStateBlock _) = "BulkStateBlock"- 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)+ show (BulkStateStream _) = "BulkStateStream"+ show (BulkStateBlock _) = "BulkStateBlock"+ show (BulkStateAEAD _) = "BulkStateAEAD"+ show BulkStateUninitialized = "BulkStateUninitialized" bulkInit :: Bulk -> BulkDirection -> BulkKey -> BulkState bulkInit bulk direction key = case bulkF bulk of- BulkBlockF ini -> BulkStateBlock (ini direction key)+ BulkBlockF ini -> BulkStateBlock (ini direction key) 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+ BulkAeadF ini -> BulkStateAEAD (ini direction key) -hasMAC (BulkBlockF _ ) = True+hasMAC, hasRecordIV :: BulkFunctions -> Bool+hasMAC (BulkBlockF _) = True hasMAC (BulkStreamF _) = True-hasMAC (BulkAeadF _ ) = False-+hasMAC (BulkAeadF _) = False hasRecordIV = hasMAC -data CipherKeyExchangeType =- CipherKeyExchange_RSA- | CipherKeyExchange_DH_Anon- | CipherKeyExchange_DHE_RSA- | CipherKeyExchange_ECDHE_RSA- | CipherKeyExchange_DHE_DSS- | CipherKeyExchange_DH_DSS- | 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 bulk = cipherBulk cipher+ where+ bulk = cipherBulk cipher -- | Check if a specific 'Cipher' is allowed to be used -- with the version specified cipherAllowedForVersion :: Version -> Cipher -> Bool cipherAllowedForVersion ver cipher = case cipherMinVer cipher of- Nothing -> ver < TLS13+ 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
@@ -1,40 +1,35 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-}--- |--- Module : Network.TLS.Compression--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Compression- ( CompressionC(..)- , Compression(..)- , CompressionID- , nullCompression- , NullCompression+{-# OPTIONS_HADDOCK hide #-} +module Network.TLS.Compression (+ CompressionC (..),+ Compression (..),+ CompressionID,+ nullCompression,+ NullCompression,+ -- * member redefined for the class abstraction- , compressionID- , compressionDeflate- , compressionInflate+ compressionID,+ compressionDeflate,+ compressionInflate, -- * helper- , compressionIntersectID- ) where+ compressionIntersectID,+) where -import Network.TLS.Types (CompressionID)-import Network.TLS.Imports import Control.Arrow (first) +import Network.TLS.Imports+import Network.TLS.Types (CompressionID)+ -- | supported compression algorithms need to be part of this class class CompressionC a where- compressionCID :: a -> CompressionID+ compressionCID :: a -> CompressionID compressionCDeflate :: a -> ByteString -> (a, ByteString) compressionCInflate :: a -> ByteString -> (a, ByteString) -- | every compression need to be wrapped in this, to fit in structure-data Compression = forall a . CompressionC a => Compression a+data Compression = forall a. CompressionC a => Compression a -- | return the associated ID for this algorithm compressionID :: Compression -> CompressionID@@ -56,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@@ -65,7 +60,7 @@ data NullCompression = NullCompression instance CompressionC NullCompression where- compressionCID _ = 0+ compressionCID _ = 0 compressionCDeflate s b = (s, b) compressionCInflate s b = (s, b)
Network/TLS/Context.hs view
@@ -1,113 +1,127 @@-{-# LANGUAGE CPP #-}--- |--- Module : Network.TLS.Context--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Context- (+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Context ( -- * Context configuration- TLSParams+ TLSParams, -- * Context object and accessor- , Context(..)- , Hooks(..)- , Established(..)- , ctxEOF- , ctxHasSSLv2ClientHello- , ctxDisableSSLv2ClientHello- , ctxEstablished- , withLog- , ctxWithHooks- , contextModifyHooks- , setEOF- , setEstablished- , contextFlush- , contextClose- , contextSend- , contextRecv- , updateMeasure- , withMeasure- , withReadLock- , withWriteLock- , withStateLock- , withRWLock+ Context (..),+ Hooks (..),+ Established (..),+ RecordLayer (..),+ ctxEOF,+ ctxEstablished,+ withLog,+ ctxWithHooks,+ contextModifyHooks,+ setEOF,+ setEstablished,+ contextFlush,+ contextClose,+ contextSend,+ contextRecv,+ updateMeasure,+ withMeasure,+ withReadLock,+ withWriteLock,+ withStateLock,+ withRWLock, -- * information- , Information(..)- , contextGetInformation+ Information (..),+ contextGetInformation, -- * New contexts- , contextNew- -- * Deprecated new contexts methods- , contextNewOnHandle-#ifdef INCLUDE_NETWORK- , contextNewOnSocket-#endif+ contextNew, -- * Context hooks- , contextHookSetHandshakeRecv- , contextHookSetHandshake13Recv- , contextHookSetCertificateRecv- , contextHookSetLogging+ contextHookSetHandshakeRecv,+ contextHookSetHandshake13Recv,+ contextHookSetCertificateRecv,+ contextHookSetLogging, -- * Using context states- , throwCore- , usingState- , usingState_- , runTxState- , runRxState- , usingHState- , getHState- , getStateRNG- , tls13orLater- , getFinished- , getPeerFinished- ) where+ throwCore,+ usingState,+ usingState_,+ runTxRecordState,+ runRxRecordState,+ usingHState,+ getHState,+ getStateRNG,+ tls13orLater,+ getTLSUnique,+ getTLSExporter,+ getTLSServerEndPoint,+ getFinished,+ getPeerFinished,+ TLS13State (..),+ getTLS13State,+ modifyTLS13State,+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef,+) where +import Control.Concurrent.MVar+import Control.Monad.State.Strict+import Data.IORef+ import Network.TLS.Backend+import Network.TLS.Cipher import Network.TLS.Context.Internal-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.State+import Network.TLS.Crypto+import Network.TLS.Handshake (+ handshakeClient,+ handshakeClientWith,+ handshakeServer,+ handshakeServerWith,+ )+import Network.TLS.Handshake.State13 import Network.TLS.Hooks-import Network.TLS.Record.State-import Network.TLS.Record.Layer-import Network.TLS.Record.Reading-import Network.TLS.Record.Writing-import Network.TLS.Parameters+import Network.TLS.Imports+import Network.TLS.KeySchedule import Network.TLS.Measurement-import Network.TLS.Types (Role(..))-import Network.TLS.Handshake (handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith)-import Network.TLS.PostHandshake (requestCertificateServer, postHandshakeAuthClientWith, postHandshakeAuthServerWith)-import Network.TLS.X509+import Network.TLS.Packet+import Network.TLS.Parameters+import Network.TLS.PostHandshake (+ postHandshakeAuthClientWith,+ requestCertificateServer,+ ) import Network.TLS.RNG--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import Data.IORef---- deprecated imports-#ifdef INCLUDE_NETWORK-import Network.Socket (Socket)-#endif-import System.IO (Handle)+import Network.TLS.Record.Recv+import Network.TLS.Record.Send+import Network.TLS.Record.State+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+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 ()+ getTLSRole :: a -> Role+ doHandshake :: a -> Context -> IO ()+ doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () instance TLSParams ClientParams where- getTLSCommonParams cparams = ( clientSupported cparams- , clientShared cparams- , clientDebug cparams- )+ getTLSCommonParams cparams =+ ( clientSupported cparams+ , clientShared cparams+ , clientDebug cparams+ ) getTLSRole _ = ClientRole doHandshake = handshakeClient doHandshakeWith = handshakeClientWith@@ -115,138 +129,183 @@ doPostHandshakeAuthWith = postHandshakeAuthClientWith instance TLSParams ServerParams where- getTLSCommonParams sparams = ( serverSupported sparams- , serverShared sparams- , serverDebug sparams- )+ getTLSCommonParams sparams =+ ( serverSupported sparams+ , serverShared sparams+ , serverDebug sparams+ ) getTLSRole _ = ServerRole doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer- doPostHandshakeAuthWith = postHandshakeAuthServerWith+ doPostHandshakeAuthWith = \_ _ _ -> return () -- | create a new context using the backend and parameters specified.-contextNew :: (MonadIO m, HasBackend backend, TLSParams params)- => backend -- ^ Backend abstraction with specific method to interact with the connection type.- -> params -- ^ Parameters of the context.- -> m Context+contextNew+ :: (MonadIO m, HasBackend backend, TLSParams params)+ => backend+ -- ^ Backend abstraction with specific method to interact with the connection type.+ -> params+ -- ^ Parameters of the context.+ -> m Context contextNew backend params = liftIO $ do initializeBackend backend let (supported, shared, debug) = getTLSCommonParams params seed <- case debugSeed debug of- Nothing -> do seed <- seedNew- debugPrintSeed debug seed- return seed- Just determ -> return determ+ Nothing -> do+ seed <- seedNew+ debugPrintSeed debug seed+ return seed+ Just determ -> return determ let rng = newStateRNG seed let role = getTLSRole params- st = newTLSState rng role+ st = newTLSState rng role - stvar <- newMVar st- eof <- newIORef False+ tlsstate <- newMVar st+ eof <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement- -- we enable the reception of SSLv2 ClientHello message only in the- -- server context, where we might be dealing with an old/compat client.- sslv2Compat <- newIORef (role == ServerRole) needEmptyPacket <- newIORef False hooks <- newIORef defaultHooks- tx <- newMVar newRecordState- rx <- newMVar newRecordState- hs <- newMVar Nothing- as <- newIORef []- crs <- newIORef []- lockWrite <- newMVar ()- lockRead <- newMVar ()- lockState <- newMVar ()- finished <- newIORef Nothing- peerFinished <- newIORef Nothing+ tx <- newMVar newRecordState+ rx <- newMVar newRecordState+ hs <- newMVar Nothing+ recvActionsRef <- newIORef []+ sendActionRef <- newIORef Nothing+ 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+ , doHandshakeWith_ = doHandshakeWith params+ , doRequestCertificate_ = doRequestCertificate params+ , doPostHandshakeAuthWith_ = doPostHandshakeAuthWith params+ } - let ctx = Context- { ctxConnection = getBackend backend- , ctxShared = shared- , ctxSupported = supported- , ctxState = stvar- , ctxFragmentSize = Just 16384- , ctxTxState = tx- , ctxRxState = rx- , ctxHandshake = hs- , ctxDoHandshake = doHandshake params- , ctxDoHandshakeWith = doHandshakeWith params- , ctxDoRequestCertificate = doRequestCertificate params- , ctxDoPostHandshakeAuthWith = doPostHandshakeAuthWith params- , ctxMeasurement = stats- , ctxEOF_ = eof- , ctxEstablished_ = established- , ctxSSLv2ClientHello = sslv2Compat- , ctxNeedEmptyPacket = needEmptyPacket- , ctxHooks = hooks- , ctxLockWrite = lockWrite- , ctxLockRead = lockRead- , ctxLockState = lockState- , ctxPendingActions = as- , ctxCertRequests = crs- , ctxKeyLogger = debugKeyLogger debug- , ctxRecordLayer = recordLayer- , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp- , ctxQUICMode = False- , ctxFinished = finished- , ctxPeerFinished = peerFinished- }+ let ctx =+ Context+ { ctxBackend = getBackend backend+ , ctxShared = shared+ , ctxSupported = supported+ , ctxDebug = debug+ , ctxTLSState = tlsstate+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref+ , ctxTxRecordState = tx+ , ctxRxRecordState = rx+ , ctxHandshakeState = hs+ , ctxRoleParams = roleParams+ , ctxMeasurement = stats+ , ctxEOF_ = eof+ , ctxEstablished_ = established+ , ctxNeedEmptyPacket = needEmptyPacket+ , ctxHooks = hooks+ , ctxLocks = locks+ , ctxPendingRecvActions = recvActionsRef+ , ctxPendingSendAction = sendActionRef+ , ctxRecordLayer = recordLayer+ , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp+ , ctxQUICMode = False+ , ctxTLS13State = st13ref+ , ctxHPKE = hpkeref+ } syncNoOp _ _ = return () - recordLayer = RecordLayer- { recordEncode = encodeRecord ctx- , recordEncode13 = encodeRecord13 ctx- , recordSendBytes = sendBytes ctx- , recordRecv = recvRecord ctx- , recordRecv13 = recvRecord13 ctx- }+ recordLayer =+ RecordLayer+ { recordEncode12 = encodeRecord12+ , recordEncode13 = encodeRecord13+ , recordSendBytes = sendBytes+ , recordRecv12 = recvRecord12+ , recordRecv13 = recvRecord13+ } return ctx --- | create a new context on an handle.-contextNewOnHandle :: (MonadIO m, TLSParams params)- => Handle -- ^ Handle of the connection.- -> params -- ^ Parameters of the context.- -> m Context-contextNewOnHandle = contextNew-{-# DEPRECATED contextNewOnHandle "use contextNew" #-}--#ifdef INCLUDE_NETWORK--- | create a new context on a socket.-contextNewOnSocket :: (MonadIO m, TLSParams params)- => Socket -- ^ Socket of the connection.- -> params -- ^ Parameters of the context.- -> m Context-contextNewOnSocket sock params = contextNew sock params-{-# DEPRECATED contextNewOnSocket "use contextNew" #-}-#endif- contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f =- contextModifyHooks context (\hooks -> hooks { hookRecvHandshake = f })+ contextModifyHooks context (\hooks -> hooks{hookRecvHandshake = f}) -contextHookSetHandshake13Recv :: Context -> (Handshake13 -> IO Handshake13) -> IO ()+contextHookSetHandshake13Recv+ :: Context -> (Handshake13 -> IO Handshake13) -> IO () contextHookSetHandshake13Recv context f =- contextModifyHooks context (\hooks -> hooks { hookRecvHandshake13 = f })+ contextModifyHooks context (\hooks -> hooks{hookRecvHandshake13 = f}) contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO () contextHookSetCertificateRecv context f =- contextModifyHooks context (\hooks -> hooks { hookRecvCertificates = f })+ contextModifyHooks context (\hooks -> hooks{hookRecvCertificates = f}) contextHookSetLogging :: Context -> Logging -> IO () contextHookSetLogging context loggingCallbacks =- contextModifyHooks context (\hooks -> hooks { hookLogging = loggingCallbacks })+ contextModifyHooks context (\hooks -> hooks{hookLogging = loggingCallbacks}) --- | Get TLS Finished sent to peer-getFinished :: Context -> IO (Maybe FinishedData)-getFinished = readIORef . ctxFinished+{-# DEPRECATED getFinished "Use getTLSUnique instead" #-} --- | Get TLS Finished received from peer-getPeerFinished :: Context -> IO (Maybe FinishedData)-getPeerFinished = readIORef . ctxPeerFinished+-- | Getting TLS Finished sent to peer.+getFinished :: Context -> IO (Maybe VerifyData)+getFinished ctx = usingState_ ctx getMyVerifyData++{-# DEPRECATED getPeerFinished "Use getTLSUnique instead" #-}++-- | Getting TLS Finished received from peer.+getPeerFinished :: Context -> IO (Maybe VerifyData)+getPeerFinished ctx = usingState_ ctx getPeerVerifyData++-- | Getting the "tls-unique" channel binding for TLS 1.2 (RFC5929).+-- For TLS 1.3, 'Nothing' is returned.+-- 'supportedExtendedMainSecret' must be 'RequireEMS'+-- But in general, it is highly recommended to upgrade to TLS 1.3+-- 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 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+ 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 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 $ TranscriptHash ""+ label' = "exporter"+ value' = hash h context+ key = hkdfExpandLabel h secret' label' value' outlen+ in Just key+ _ -> Nothing++-- | Getting the "tls-server-end-point" channel binding for TLS 1.2+-- (RFC5929). For 1.3, there is no specifications for how to create+-- it. In this implementation, a certificate chain without+-- extensions is hashed like TLS 1.2.+getTLSServerEndPoint :: Context -> IO (Maybe ByteString)+getTLSServerEndPoint ctx = do+ mcc <- usingState_ ctx getServerCertificateChain+ case mcc of+ Nothing -> return Nothing+ Just cc -> do+ (usedHash, _, _, _) <- getRxRecordState ctx+ return $ Just $ hash usedHash $ encodeCertificate cc
Network/TLS/Context/Internal.hs view
@@ -1,78 +1,102 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}--- |--- Module : Network.TLS.Context.Internal--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Context.Internal- (++module Network.TLS.Context.Internal ( -- * Context configuration- ClientParams(..)- , ServerParams(..)- , defaultParamsClient- , SessionID- , SessionData(..)- , MaxFragmentEnum(..)- , Measurement(..)+ ClientParams (..),+ ServerParams (..),+ defaultParamsClient,+ SessionID,+ SessionData (..),+ MaxFragmentEnum (..),+ Measurement (..), -- * Context object and accessor- , Context(..)- , Hooks(..)- , Established(..)- , PendingAction(..)- , ctxEOF- , ctxHasSSLv2ClientHello- , ctxDisableSSLv2ClientHello- , ctxEstablished- , withLog- , ctxWithHooks- , contextModifyHooks- , setEOF- , setEstablished- , contextFlush- , contextClose- , contextSend- , contextRecv- , updateRecordLayer- , updateMeasure- , withMeasure- , withReadLock- , withWriteLock- , withStateLock- , withRWLock+ Context (..),+ Hooks (..),+ Limit (..),+ Established (..),+ PendingRecvAction (..),+ RecordLayer (..),+ Locks (..),+ RoleParams (..),+ ctxEOF,+ ctxEstablished,+ withLog,+ ctxWithHooks,+ contextModifyHooks,+ setEOF,+ setEstablished,+ contextFlush,+ contextClose,+ contextSend,+ contextRecv,+ updateRecordLayer,+ updateMeasure,+ withMeasure,+ withReadLock,+ withWriteLock,+ withStateLock,+ withRWLock, -- * information- , Information(..)- , contextGetInformation+ Information (..),+ contextGetInformation, -- * Using context states- , throwCore- , failOnEitherError- , usingState- , usingState_- , runTxState- , runRxState- , usingHState- , getHState- , saveHState- , restoreHState- , getStateRNG- , tls13orLater- , addCertRequest13- , getCertRequest13- , decideRecordVersion+ throwCore,+ failOnEitherError,+ usingState,+ usingState_,+ runTxRecordState,+ runRxRecordState,+ usingHState,+ getHState,+ saveHState,+ restoreHState,+ getStateRNG,+ tls13orLater,+ decideRecordVersion, -- * Misc- , HandshakeSync(..)- ) where+ HandshakeSync (..),+ TLS13State (..),+ defaultTLS13State,+ getTLS13State,+ modifyTLS13State,+ 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 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 import Network.TLS.Handshake.State@@ -80,7 +104,7 @@ import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters-import Network.TLS.Record.Layer+import Network.TLS.Record import Network.TLS.Record.State import Network.TLS.State import Network.TLS.Struct@@ -88,81 +112,174 @@ import Network.TLS.Types import Network.TLS.Util -import Control.Concurrent.MVar-import Control.Exception (throwIO)-import Control.Monad.State.Strict-import qualified Data.ByteString as B-import Data.IORef-import Data.Tuple+-- | A TLS Context keep tls specific state, parameters and backend information.+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+ -- ^ has the handle EOFed or not.+ , ctxEstablished_ :: IORef Established+ -- ^ has the handshake been done and been successful.+ , ctxTxRecordState :: MVar RecordState+ -- ^ current TX record state+ , ctxRxRecordState :: MVar RecordState+ -- ^ current RX record state+ , ctxHandshakeState :: MVar (Maybe HandshakeState)+ -- ^ optional handshake state+ , ctxRoleParams :: RoleParams+ -- ^ hooks for this context+ , ctxLocks :: Locks+ , ctxHooks :: IORef Hooks+ , -- TLS 1.3+ ctxTLS13State :: IORef TLS13State+ , ctxPendingRecvActions :: IORef [PendingRecvAction]+ , ctxPendingSendAction :: IORef (Maybe (Context -> IO ()))+ -- ^ pending post handshake authentication requests+ , -- QUIC+ ctxRecordLayer :: RecordLayer a+ , ctxHandshakeSync :: HandshakeSync+ , ctxQUICMode :: Bool+ , -- Misc+ ctxNeedEmptyPacket :: IORef Bool+ -- ^ empty packet workaround for CBC guessability.+ , 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))+ } --- | Information related to a running context, e.g. current cipher-data Information = Information- { infoVersion :: Version- , infoCipher :: Cipher- , infoCompression :: Compression- , infoMasterSecret :: Maybe ByteString- , infoExtendedMasterSec :: Bool- , infoClientRandom :: Maybe ClientRandom- , infoServerRandom :: Maybe ServerRandom- , infoNegotiatedGroup :: Maybe Group- , infoTLS13HandshakeMode :: Maybe HandshakeMode13- , infoIsEarlyDataAccepted :: Bool- } deriving (Show,Eq)+type HPKEF = ByteString -> ByteString -> IO ByteString --- | A TLS Context keep tls specific state, parameters and backend information.-data Context = forall bytes . Monoid bytes => Context- { ctxConnection :: Backend -- ^ return the backend object associated with this context- , ctxSupported :: Supported- , ctxShared :: Shared- , ctxState :: MVar TLSState- , ctxMeasurement :: IORef Measurement- , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not.- , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful.- , ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability.- , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello.- -- the flag will be set to false regardless of its initial value- -- after the first packet received.- , ctxFragmentSize :: Maybe Int -- ^ maximum size of plaintext fragments- , ctxTxState :: MVar RecordState -- ^ current tx state- , ctxRxState :: MVar RecordState -- ^ current rx state- , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state- , ctxDoHandshake :: Context -> IO ()- , ctxDoHandshakeWith :: Context -> Handshake -> IO ()- , ctxDoRequestCertificate :: Context -> IO Bool- , ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO ()- , ctxHooks :: IORef Hooks -- ^ hooks for this context- , ctxLockWrite :: MVar () -- ^ lock to use for writing data (including updating the state)- , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state)- , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet.- -- it is usually nested in a write or read lock.- , ctxPendingActions :: IORef [PendingAction]- , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests- , ctxKeyLogger :: String -> IO ()- , ctxRecordLayer :: RecordLayer bytes- , ctxHandshakeSync :: HandshakeSync- , ctxQUICMode :: Bool- , ctxFinished :: IORef (Maybe FinishedData)- , ctxPeerFinished :: IORef (Maybe FinishedData)+data RecordLimit+ = NoRecordLimit -- for QUIC+ | RecordLimit+ Int -- effective+ (Maybe Int) -- pending+ deriving (Eq, Show)++data RoleParams = RoleParams+ { doHandshake_ :: Context -> IO ()+ , doHandshakeWith_ :: Context -> HandshakeR -> IO ()+ , doRequestCertificate_ :: Context -> IO Bool+ , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO () } -data HandshakeSync = HandshakeSync (Context -> ClientState -> IO ())- (Context -> ServerState -> IO ())+data Locks = Locks+ { lockWrite :: MVar ()+ -- ^ lock to use for writing data (including updating the state)+ , lockRead :: MVar ()+ -- ^ lock to use for reading data (including updating the state)+ , lockState :: MVar ()+ -- ^ lock used during read/write when receiving and sending packet.+ -- it is usually nested in a write or read lock.+ } -updateRecordLayer :: Monoid bytes => RecordLayer bytes -> Context -> Context+data CipherChoice = CipherChoice+ { cVersion :: Version+ , cCipher :: Cipher+ , cHash :: Hash+ , cZero :: Secret+ }+ deriving (Show)++makeCipherChoice :: Version -> Cipher -> CipherChoice+makeCipherChoice ver cipher = CipherChoice ver cipher h zero+ where+ h = cipherHash cipher+ zero = BA.replicate (hashDigestSize h) 0++data TLS13State = TLS13State+ { tls13stRecvNST :: Bool -- client+ , tls13stSentClientCert :: Bool -- client+ , tls13stRecvSF :: Bool -- client+ , tls13stSentCF :: Bool -- client+ , tls13stRecvCF :: Bool -- server+ , tls13stPendingRecvData :: Maybe ByteString -- client+ , tls13stPendingSentData :: [ByteString] -> [ByteString] -- client+ , tls13stRTT :: Millisecond+ , tls13st0RTT :: Bool -- client+ , tls13st0RTTAccepted :: Bool -- client+ , 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]+ }++defaultTLS13State :: TLS13State+defaultTLS13State =+ TLS13State+ { tls13stRecvNST = False+ , tls13stSentClientCert = False+ , tls13stRecvSF = False+ , tls13stSentCF = False+ , tls13stRecvCF = False+ , tls13stPendingRecvData = Nothing+ , tls13stPendingSentData = id+ , tls13stRTT = 0+ , tls13st0RTT = False+ , tls13st0RTTAccepted = False+ , tls13stClientExtensions = []+ , tls13stChoice = undefined+ , tls13stHsKey = Nothing+ , tls13stSession = Session Nothing+ , tls13stSentExtensions = []+ }++getTLS13State :: Context -> IO TLS13State+getTLS13State Context{..} = readIORef ctxTLS13State++modifyTLS13State :: Context -> (TLS13State -> TLS13State) -> IO ()+modifyTLS13State Context{..} f = atomicModifyIORef' ctxTLS13State $ \st -> (f st, ())++data HandshakeSync+ = HandshakeSync+ (Context -> ClientState -> IO ())+ (Context -> ServerState -> IO ())++{- FOURMOLU_DISABLE -}+data RecordLayer a = RecordLayer+ { -- Writing.hs+ recordEncode12 :: Context -> Record Plaintext -> IO (Either TLSError a)+ , recordEncode13 :: Context -> Record Plaintext -> IO (Either TLSError a)+ , recordSendBytes :: Context -> a -> IO ()+ , -- Reading.hs+ recordRecv12 :: Context -> IO (Either TLSError (Record Plaintext))+ , recordRecv13 :: Context -> IO (Either TLSError (Record Plaintext))+ }+{- FOURMOLU_ENABLE -}++updateRecordLayer :: Monoid a => RecordLayer a -> Context -> Context updateRecordLayer recordLayer Context{..} =- Context { ctxRecordLayer = recordLayer, .. }+ Context{ctxRecordLayer = recordLayer, ..} -data Established = NotEstablished- | EarlyDataAllowed Int -- remaining 0-RTT bytes allowed- | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip- | Established- deriving (Eq, Show)+data Established+ = NotEstablished+ | EarlyDataAllowed Int -- server: remaining 0-RTT bytes allowed+ | EarlyDataNotAllowed Int -- sever: remaining 0-RTT packets allowed to skip+ | EarlyDataSending+ | Established+ deriving (Eq, Show) -data PendingAction- = PendingAction Bool (Handshake13 -> IO ())- -- ^ simple pending action- | PendingActionHash Bool (ByteString -> Handshake13 -> IO ())- -- ^ pending action taking transcript hash up to preceding message+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+ (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx)@@ -170,51 +287,67 @@ withMeasure :: Context -> (Measurement -> IO a) -> IO a withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f --- | A shortcut for 'backendFlush . ctxConnection'.+-- | A shortcut for 'backendFlush . ctxBackend'. contextFlush :: Context -> IO ()-contextFlush = backendFlush . ctxConnection+contextFlush = backendFlush . ctxBackend --- | A shortcut for 'backendClose . ctxConnection'.+-- | A shortcut for 'backendClose . ctxBackend'. contextClose :: Context -> IO ()-contextClose = backendClose . ctxConnection+contextClose = backendClose . ctxBackend -- | Information about the current context contextGetInformation :: Context -> IO (Maybe Information) contextGetInformation ctx = do- ver <- usingState_ ctx $ gets stVersion+ 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 -> (hstMasterSecret st,- hstExtendedMasterSec st,- Just (hstClientRandom st),- hstServerRandom st,- if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing,- hstNegotiatedGroup st)- Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing)- (cipher,comp) <- readMVar (ctxRxState ctx) <&> \st -> (stCipher st, stCompression st)+ Just st ->+ ( hstMainSecret st+ , hstExtendedMainSecret st+ , Just (hstClientRandom st)+ , hstServerRandom st+ , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing+ , hstSupportedGroup st+ , hstTLS13ECHAccepted st+ )+ 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 getTLS12SessionResuming case (ver, cipher) of- (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted- _ -> return Nothing+ (Just v, Just c) ->+ return $+ Just $+ 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 ()-contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b+contextSend c b =+ updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxBackend c) b contextRecv :: Context -> Int -> IO ByteString-contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz+contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxBackend c) sz ctxEOF :: Context -> IO Bool ctxEOF ctx = readIORef $ ctxEOF_ ctx -ctxHasSSLv2ClientHello :: Context -> IO Bool-ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx--ctxDisableSSLv2ClientHello :: Context -> IO ()-ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False- setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True @@ -225,7 +358,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)@@ -234,40 +367,40 @@ withLog ctx f = ctxWithHooks ctx (f . hookLogging) throwCore :: MonadIO m => TLSError -> m a-throwCore = liftIO . throwIO+throwCore = liftIO . throwIO . Uncontextualized failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a failOnEitherError f = do ret <- f case ret of Left err -> throwCore err- Right r -> return r+ Right r -> return r usingState :: Context -> TLSSt a -> IO (Either TLSError a) usingState ctx f =- modifyMVar (ctxState ctx) $ \st ->- let (a, newst) = runTLSState f st- in newst `seq` return (newst, a)+ modifyMVar (ctxTLSState ctx) $ \st ->+ let (a, newst) = runTLSState f st+ in newst `seq` return (newst, a) usingState_ :: Context -> TLSSt a -> IO a usingState_ ctx f = failOnEitherError $ usingState ctx f usingHState :: MonadIO m => Context -> HandshakeM a -> m a-usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst ->- case mst of- Nothing -> throwCore $ Error_Misc "missing handshake"- Just st -> return $ swap (Just <$> runHandshake st f)+usingHState ctx f = liftIO $ modifyMVar (ctxHandshakeState ctx) $ \case+ Nothing -> liftIO $ throwIO MissingHandshake+ Just st -> return $ swap (Just <$> runHandshake st f) getHState :: MonadIO m => Context -> m (Maybe HandshakeState)-getHState ctx = liftIO $ readMVar (ctxHandshake ctx)+getHState ctx = liftIO $ readMVar (ctxHandshakeState ctx) saveHState :: Context -> IO (Saved (Maybe HandshakeState))-saveHState ctx = saveMVar (ctxHandshake ctx)+saveHState ctx = saveMVar (ctxHandshakeState ctx) -restoreHState :: Context- -> Saved (Maybe HandshakeState)- -> IO (Saved (Maybe HandshakeState))-restoreHState ctx = restoreMVar (ctxHandshake ctx)+restoreHState+ :: Context+ -> Saved (Maybe HandshakeState)+ -> IO (Saved (Maybe HandshakeState))+restoreHState ctx = restoreMVar (ctxHandshakeState ctx) decideRecordVersion :: Context -> IO (Version, Bool) decideRecordVersion ctx = usingState_ ctx $ do@@ -277,63 +410,122 @@ -- The record version of the first ClientHello SHOULD be TLS 1.0. -- The record version of the second ClientHello MUST be TLS 1.2. let ver'- | ver >= TLS13 = if hrr then TLS12 else TLS10- | otherwise = ver+ | ver >= TLS13 = if hrr then TLS12 else TLS10+ | otherwise = ver return (ver', ver >= TLS13) -runTxState :: Context -> RecordM a -> IO (Either TLSError a)-runTxState ctx f = do+runTxRecordState :: Context -> RecordM a -> IO (Either TLSError a)+runTxRecordState ctx f = do (ver, tls13) <- decideRecordVersion ctx- let opt = RecordOptions { recordVersion = ver- , recordTLS13 = tls13- }- modifyMVar (ctxTxState ctx) $ \st ->+ let opt =+ RecordOptions+ { recordVersion = ver+ , recordTLS13 = tls13+ }+ modifyMVar (ctxTxRecordState ctx) $ \st -> case runRecordM f opt st of- Left err -> return (st, Left err)+ Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) -runRxState :: Context -> RecordM a -> IO (Either TLSError a)-runRxState ctx f = do- ver <- usingState_ ctx getVersion+runRxRecordState :: Context -> RecordM a -> IO (Either TLSError a)+runRxRecordState ctx f = do+ ver <-+ usingState_+ ctx+ (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) -- For 1.3, ver is just ignored. So, it is not necessary to convert ver.- let opt = RecordOptions { recordVersion = ver- , recordTLS13 = ver >= TLS13- }- modifyMVar (ctxRxState ctx) $ \st ->+ let opt =+ RecordOptions+ { recordVersion = ver+ , recordTLS13 = ver >= TLS13+ }+ modifyMVar (ctxRxRecordState ctx) $ \st -> case runRecordM f opt st of- Left err -> return (st, Left err)+ Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) getStateRNG :: Context -> Int -> IO ByteString getStateRNG ctx n = usingState_ ctx $ genRandom n withReadLock :: Context -> IO a -> IO a-withReadLock ctx f = withMVar (ctxLockRead ctx) (const f)+withReadLock ctx f = withMVar (lockRead $ ctxLocks ctx) (const f) withWriteLock :: Context -> IO a -> IO a-withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f)+withWriteLock ctx f = withMVar (lockWrite $ ctxLocks ctx) (const f) withRWLock :: Context -> IO a -> IO a withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f withStateLock :: Context -> IO a -> IO a-withStateLock ctx f = withMVar (ctxLockState ctx) (const f)+withStateLock ctx f = withMVar (lockState $ ctxLocks ctx) (const f) tls13orLater :: MonadIO m => Context -> m Bool tls13orLater ctx = do- ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme+ ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS12 return $ case ev of- Left _ -> False- Right v -> v >= TLS13+ 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 (\(CertRequest13 c _) -> context == c) 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+ 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,87 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-}--- |--- Module : Network.TLS.Core--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Core- (++module Network.TLS.Core ( -- * Internal packet sending and receiving- sendPacket- , recvPacket+ sendPacket12,+ recvPacket12, -- * Initialisation and Termination of context- , bye- , handshake+ bye,+ handshake, -- * Application Layer Protocol Negotiation- , getNegotiatedProtocol+ getNegotiatedProtocol, -- * Server Name Indication- , getClientSNI+ getClientSNI, -- * High level API- , sendData- , recvData- , recvData'- , updateKey- , KeyUpdateRequest(..)- , requestCertificate- ) where+ sendData,+ recvData,+ recvData',+ updateKey,+ KeyUpdateRequest (..),+ requestCertificate,+) where -import Network.TLS.Cipher+import qualified Control.Exception as E+import Control.Monad.State.Strict+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as L+import Data.IORef+import System.Timeout+ import Network.TLS.Context-import Network.TLS.Crypto-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.State (getSession)-import Network.TLS.Parameters-import Network.TLS.IO-import Network.TLS.Session+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.Server 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.PostHandshake-import Network.TLS.KeySchedule-import Network.TLS.Types (Role(..), HostName, AnyTrafficSecret(..), ApplicationSecret)-import Network.TLS.Util (catchException, mapChunks_)-import Network.TLS.Extension+import Network.TLS.Session+import Network.TLS.State (getRole, getSession) import qualified Network.TLS.State as S-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Lazy as L-import Control.Monad (unless, when)-import qualified Control.Exception as E+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types (+ HostName,+ Role (..),+ )+import Network.TLS.Util (catchException, mapChunks_) -import Control.Monad.State.Strict+-- | Handshake for a new TLS connection+-- This is to be called at the beginning of a connection, and during renegotiation.+-- Don't use this function as the acquire resource of 'bracket'.+handshake :: MonadIO m => Context -> m ()+handshake ctx = do+ handshake_ ctx+ -- Trying to receive an alert of client authentication failure+ liftIO $ do+ role <- usingState_ ctx getRole+ tls13 <- tls13orLater ctx+ sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx+ when (role == ClientRole && tls13 && sentClientCert) $ do+ rtt <- getRTT ctx+ -- This 'timeout' should work.+ mdat <- timeout rtt $ recvData13 ctx+ case mdat of+ Nothing -> return ()+ Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat} --- | notify the context that this side wants to close connection.--- this is important that it is called before closing the handle, otherwise+rttFactor :: Int+rttFactor = 3++getRTT :: Context -> IO Int+getRTT ctx = do+ rtt <- tls13stRTT <$> getTLS13State ctx+ 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 -- 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+ tls13 <- tls13orLater ctx+ when (tls13 && not eof) $ do+ role <- usingState_ ctx getRole+ if role == ClientRole+ then do+ withWriteLock ctx $ sendCFifNecessary ctx+ -- receiving NewSessionTicket+ let chk = tls13stRecvNST <$> getTLS13State ctx+ recvNST <- chk+ unless recvNST $ do+ rtt <- getRTT ctx+ void $ timeout rtt $ recvHS13 ctx chk+ else do+ -- receiving Client Finished+ let chk = tls13stRecvCF <$> getTLS13State ctx+ recvCF <- chk+ unless recvCF $ do+ -- no chance to measure RTT before receiving CF+ -- fixme: 1sec is good enough?+ let rtt = 1000000+ void $ timeout rtt $ recvHS13 ctx chk+ bye_ ctx++bye_ :: MonadIO m => Context -> m ()+bye_ ctx = liftIO $ do -- Although setEOF is always protected by the read lock, here we don't try -- to wrap ctxEOF with it, so that function bye can still be called -- concurrently to a blocked recvData. eof <- ctxEOF ctx tls13 <- tls13orLater ctx- unless eof $ withWriteLock ctx $- if tls13 then- sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)]- else- sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]+ unless eof $+ withWriteLock ctx $+ if tls13+ then sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)]+ else sendPacket12 ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | 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@@ -89,25 +153,47 @@ getClientSNI :: MonadIO m => Context -> m (Maybe HostName) getClientSNI ctx = liftIO $ usingState_ ctx S.getClientSNI +sendCFifNecessary :: Context -> IO ()+sendCFifNecessary ctx = do+ st <- getTLS13State ctx+ let recvSF = tls13stRecvSF st+ sentCF = tls13stSentCF st+ when (recvSF && not sentCF) $ do+ msend <- readIORef (ctxPendingSendAction ctx)+ case msend of+ Nothing -> return ()+ Just sendAction -> do+ sendAction ctx+ writeIORef (ctxPendingSendAction ctx) Nothing+ -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => Context -> L.ByteString -> m ()+sendData _ "" = return () sendData ctx dataToSend = liftIO $ do tls13 <- tls13orLater ctx- let sendP- | tls13 = sendPacket13 ctx . AppData13- | otherwise = sendPacket ctx . AppData+ let sendP bs+ | tls13 = do+ sendPacket13 ctx $ AppData13 bs+ role <- usingState_ ctx getRole+ sentCF <- tls13stSentCF <$> getTLS13State ctx+ rtt0 <- tls13st0RTT <$> getTLS13State ctx+ when (role == ClientRole && rtt0 && not sentCF) $+ modifyTLS13State ctx $+ \st -> st{tls13stPendingSentData = tls13stPendingSentData st . (bs :)}+ | otherwise = sendPacket12 ctx $ AppData bs+ when tls13 $ withWriteLock ctx $ sendCFifNecessary ctx withWriteLock ctx $ do checkValid ctx -- 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@@ -116,220 +202,311 @@ -- packet, because don't want another thread to receive a new packet -- before this one has been fully processed. --- -- Even when recvData1/recvData13 loops, we only need to call function+ -- Even when recvData12/recvData13 loops, we only need to call function -- checkValid once. Since we hold the read lock, no concurrent call -- will impact the validity of the context.- if tls13 then recvData13 ctx else recvData1 ctx--recvData1 :: Context -> IO B.ByteString-recvData1 ctx = do- pkt <- recvPacket ctx- either (onError terminate) process pkt- where process (Handshake [ch@ClientHello{}]) =- handshakeWith ctx ch >> recvData1 ctx- process (Handshake [hr@HelloRequest]) =- handshakeWith ctx hr >> recvData1 ctx+ if tls13 then recvData13 ctx else recvData12 ctx - process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty- process (Alert [(AlertLevel_Fatal, desc)]) = do- setEOF ctx- E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))+recvData12 :: Context -> IO ByteString+recvData12 ctx = do+ pkt <- recvPacket12 ctx+ either (onError terminate12) process pkt+ where+ process (Handshake [ch@ClientHello{}] [b]) =+ handshakeWith ctx (ch, b) >> recvData12 ctx+ process (Handshake [hr@HelloRequest] [b]) =+ handshakeWith ctx (hr, b) >> recvData12 ctx+ -- UserCanceled should be followed by a close_notify.+ -- fixme: is it safe to call recvData12?+ process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty+ process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty+ process (Alert [(AlertLevel_Fatal, desc)]) = do+ setEOF ctx+ E.throwIO+ ( Terminated+ True+ ("received fatal error: " ++ show desc)+ (Error_Protocol "remote side fatal error" desc)+ ) - -- when receiving empty appdata, we just retry to get some data.- process (AppData "") = recvData1 ctx- process (AppData x) = return x- process p = let reason = "unexpected message " ++ show p in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- when receiving empty appdata, we just retry to get some data.+ process (AppData "") = recvData12 ctx+ process (AppData x) = return x+ process p = do+ let reason = "unexpected message " ++ show p+ terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - terminate = terminateWithWriteLock ctx (sendPacket ctx . Alert)+ terminate12 = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) -recvData13 :: Context -> IO B.ByteString+recvData13 :: Context -> IO ByteString recvData13 ctx = do- pkt <- recvPacket13 ctx- either (onError terminate) process pkt- where process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty- process (Alert13 [(AlertLevel_Fatal, desc)]) = do- setEOF ctx- E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))- process (Handshake13 hs) = do- loopHandshake13 hs- recvData13 ctx- -- when receiving empty appdata, we just retry to get some data.- process (AppData13 "") = recvData13 ctx- process (AppData13 x) = do- let chunkLen = C8.length x- established <- ctxEstablished ctx- case established of- EarlyDataAllowed maxSize+ mdat <- tls13stPendingRecvData <$> getTLS13State ctx+ case mdat of+ Nothing -> do+ pkt <- recvPacket13 ctx+ either (onError (terminate13 ctx)) process pkt+ Just dat -> do+ modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing}+ return dat+ where+ -- UserCanceled MUST be followed by a CloseNotify.+ process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty+ process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty+ process (Alert13 [(AlertLevel_Fatal, desc)]) = do+ setEOF ctx+ E.throwIO+ ( Terminated+ True+ ("received fatal error: " ++ show desc)+ (Error_Protocol "remote side fatal error" desc)+ )+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs+ recvData13 ctx+ -- when receiving empty appdata, we just retry to get some data.+ process (AppData13 "") = recvData13 ctx+ process (AppData13 x) = do+ let chunkLen = C8.length x+ established <- ctxEstablished ctx+ case established of+ EarlyDataAllowed maxSize | chunkLen <= maxSize -> do setEstablished ctx $ EarlyDataAllowed (maxSize - chunkLen) return x | otherwise ->- let reason = "early data overflow" in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- EarlyDataNotAllowed n- | n > 0 -> do+ let reason = "early data overflow"+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ EarlyDataNotAllowed n+ | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x"- | otherwise ->- let reason = "early data deprotect overflow" in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Established -> return x- NotEstablished -> throwCore $ Error_Protocol ("data at not-established", True, UnexpectedMessage)- process ChangeCipherSpec13 = do- established <- ctxEstablished ctx- if established /= Established then- recvData13 ctx- else do+ | otherwise -> do+ let reason = "early data deprotect overflow"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ Established -> return x+ _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage+ process ChangeCipherSpec13 = do+ established <- ctxEstablished ctx+ if established /= Established+ then recvData13 ctx+ else do let reason = "CSS after Finished"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- process p = let reason = "unexpected message " ++ show p in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ process p = do+ let reason = "unexpected message " ++ show p+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - loopHandshake13 [] = return ()- loopHandshake13 (ClientHello13{}:_) = do- let reason = "Client hello is not allowed"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- -- 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- role <- usingState_ ctx S.isClientContext- unless (role == ClientRole) $- let reason = "Session ticket is allowed for client only"- in terminate (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 resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret- (_, usedCipher, _, _) <- getTxState ctx- let choice = makeCipherChoice TLS13 usedCipher- psk = derivePSK choice resumptionMasterSecret nonce- maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of- Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms- _ -> 0- 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- sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata- -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec"- loopHandshake13 hs- loopHandshake13 (KeyUpdate13 mode:hs) = do- when (ctxQUICMode ctx) $ do- let reason = "KeyUpdate is not allowed for QUIC"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- checkAlignment hs- established <- ctxEstablished ctx- -- Though RFC 8446 Sec 4.6.3 does not clearly says,- -- unidirectional key update is legal.- -- So, we don't have to check if this key update is corresponding- -- to key update (update_requested) which we sent.- if established == Established then do- keyUpdate ctx getRxState setRxState+ loopHandshake13 [] = return ()+ -- fixme: some implementations send multiple NST at the same time.+ -- Only the first one is used at this moment.+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do+ role <- usingState_ ctx S.getRole+ unless (role == ClientRole) $ do+ let reason = "Session ticket is allowed for client only"+ 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 =+ 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 ticket' = B.copy ticket+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata+ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}+ loopHandshake13 hbs+ loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do+ let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs+ when multipleKeyUpdate $ do+ let reason = "Multiple KeyUpdate is not allowed in one record"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ when (ctxQUICMode ctx) $ do+ let reason = "KeyUpdate is not allowed for QUIC"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ checkAlignment ctx+ established <- ctxEstablished ctx+ -- Though RFC 8446 Sec 4.6.3 does not clearly says,+ -- unidirectional key update is legal.+ -- So, we don't have to check if this key update is corresponding+ -- to key update (update_requested) which we sent.+ if established == Established+ then do+ keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]- keyUpdate ctx getTxState setTxState- loopHandshake13 hs- else do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] []+ keyUpdate ctx getTxRecordState setTxRecordState+ loopHandshake13 hbs+ else do let reason = "received key update before established"- terminate (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- mPendingAction <- popPendingAction ctx- case mPendingAction of- Nothing -> let reason = "unexpected handshake message " ++ show h in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Just action -> do- -- Pending actions are executed with read+write locks, just- -- like regular handshake code.- withWriteLock ctx $ handleException ctx $- case action of- PendingAction needAligned pa -> do- when needAligned $ checkAlignment hs- processHandshake13 ctx h >> pa h- PendingActionHash needAligned pa -> do- when needAligned $ checkAlignment hs- d <- transcriptHash ctx- processHandshake13 ctx h- pa d h- loopHandshake13 hs+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- Client only+ loopHandshake13 ((h@CertRequest13{}, _b) : hbs) =+ postHandshakeAuthWith ctx h >> loopHandshake13 hbs+ loopHandshake13 (hb@(h, _) : hbs) = do+ rtt0 <- tls13st0RTT <$> getTLS13State ctx+ when rtt0 $ case h of+ ServerHello13 SH{..} ->+ when (isHelloRetryRequest shRandom) $ do+ clearTxRecordState ctx+ let reason = "HRR is not allowed for 0-RTT"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ _ -> return ()+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs - terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)+recvHS13 :: Context -> IO Bool -> IO ()+recvHS13 ctx breakLoop = do+ pkt <- recvPacket13 ctx+ -- fixme: Left+ either (\_ -> return ()) process pkt+ where+ -- UserCanceled MUST be followed by a CloseNotify.+ process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx+ process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs+ stop <- breakLoop+ unless stop $ recvHS13 ctx breakLoop+ process _ = recvHS13 ctx breakLoop - checkAlignment hs = do- complete <- isRecvComplete ctx- unless (complete && null hs) $- let reason = "received message not aligned with record boundary"- in terminate (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 (SessionIDorTicket_ ticket) exts, _b) : hbs) = do+ role <- usingState_ ctx S.getRole+ unless (role == ClientRole) $ do+ let reason = "Session ticket is allowed for client only"+ 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+ let choice = makeCipherChoice TLS13 usedCipher+ psk = derivePSK choice resumptionSecret nonce+ 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 ticket' = B.copy ticket+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata+ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}+ 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 -> Handshake13R -> IO Bool+popAction ctx hb@(h, _b) = do+ mPendingRecvAction <- popPendingRecvAction ctx+ case mPendingRecvAction of+ Nothing -> return False+ Just action -> do+ -- Pending actions are executed with read+write locks, just+ -- like regular handshake code.+ withWriteLock ctx $+ handleException ctx $ do+ case action of+ PendingRecvAction needAligned pa -> do+ when needAligned $ checkAlignment ctx+ updateTranscriptHash13 ctx hb+ pa h+ PendingRecvActionSelfUpdate needAligned pa -> do+ when needAligned $ checkAlignment ctx+ pa hb+ PendingRecvActionHash needAligned pa -> do+ when needAligned $ checkAlignment ctx+ d <- transcriptHash ctx "Pending action"+ updateTranscriptHash13 ctx hb+ pa d h+ -- Client: after receiving SH, app data is coming.+ -- this loop tries to receive it.+ -- App key must be installed before receiving+ -- the app data.+ sendCFifNecessary ctx+ return True++checkAlignment :: Context -> IO ()+checkAlignment ctx = do+ complete <- isRecvComplete ctx+ unless complete $ do+ let reason = "received message not aligned with record boundary"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions tryBye :: Context -> IO ()-tryBye ctx = catchException (bye ctx) (\_ -> return ())+tryBye ctx = catchException (bye_ ctx) (\_ -> return ()) -onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)- -> TLSError -> m B.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+ :: Monad m+ => (TLSError -> AlertLevel -> AlertDescription -> String -> m ByteString)+ -> TLSError+ -> m ByteString+onError _ Error_EOF =+ -- Not really an error.+ return B.empty+onError terminate err = terminate err lvl ad reason+ where+ (lvl, ad) = errorToAlert err+ reason = errorToAlertMessage err -terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ())- -> TLSError -> AlertLevel -> 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+ :: Context+ -> ([(AlertLevel, AlertDescription)] -> IO ())+ -> TLSError+ -> AlertLevel+ -> AlertDescription+ -> String+ -> IO a+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 Nothing -> 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" #-}+ -- | 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", True, 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 = OneWay -- ^ Unidirectional key update- | TwoWay -- ^ Bidirectional key update (normal case)- 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 getTxState setTxState- return tls13+recvData' ctx = L.fromChunks . (: []) <$> recvData ctx
Network/TLS/Credentials.hs view
@@ -1,34 +1,29 @@--- |--- Module : Network.TLS.Credentials--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown--- {-# LANGUAGE CPP #-}-module Network.TLS.Credentials- ( Credential- , Credentials(..)- , credentialLoadX509- , credentialLoadX509FromMemory- , credentialLoadX509Chain- , credentialLoadX509ChainFromMemory- , credentialsFindForSigning- , credentialsFindForDecrypting- , credentialsListSigningAlgorithms- , credentialPublicPrivateKeys- , credentialMatchesHashSignatures- ) where+{-# OPTIONS_GHC -Wno-orphans #-} -import Network.TLS.Crypto-import Network.TLS.X509-import Network.TLS.Imports+module Network.TLS.Credentials (+ Credential,+ Credentials (..),+ credentialLoadX509,+ credentialLoadX509FromMemory,+ credentialLoadX509Chain,+ credentialLoadX509ChainFromMemory,+ credentialsFindForSigning,+ credentialsFindForDecrypting,+ credentialsListSigningAlgorithms,+ credentialPublicPrivateKeys,+ credentialMatchesHashSignatures,+) where++import Data.X509+import qualified Data.X509 as X509 import Data.X509.File import Data.X509.Memory-import Data.X509 -import qualified Data.X509 as X509-import qualified Network.TLS.Struct as TLS+import Network.TLS.Crypto+import Network.TLS.Imports+import qualified Network.TLS.Struct as TLS+import Network.TLS.X509 type Credential = (CertificateChain, PrivKey) @@ -46,60 +41,71 @@ -- | try to create a new credential object from a public certificate -- and the associated private key that are stored on the filesystem -- in PEM format.-credentialLoadX509 :: FilePath -- ^ public certificate (X.509 format)- -> FilePath -- ^ private key associated- -> IO (Either String Credential)+credentialLoadX509+ :: FilePath+ -- ^ public certificate (X.509 format)+ -> FilePath+ -- ^ private key associated+ -> IO (Either String Credential) credentialLoadX509 certFile = credentialLoadX509Chain certFile [] -- | similar to 'credentialLoadX509' but take the certificate -- and private key from memory instead of from the filesystem.-credentialLoadX509FromMemory :: ByteString- -> ByteString- -> Either String Credential+credentialLoadX509FromMemory+ :: ByteString+ -> ByteString+ -> Either String Credential credentialLoadX509FromMemory certData =- credentialLoadX509ChainFromMemory certData []+ credentialLoadX509ChainFromMemory certData [] -- | similar to 'credentialLoadX509' but also allow specifying chain -- certificates.-credentialLoadX509Chain ::- FilePath -- ^ public certificate (X.509 format)- -> [FilePath] -- ^ chain certificates (X.509 format)- -> FilePath -- ^ private key associated- -> IO (Either String Credential)+credentialLoadX509Chain+ :: FilePath+ -- ^ public certificate (X.509 format)+ -> [FilePath]+ -- ^ chain certificates (X.509 format)+ -> FilePath+ -- ^ private key associated+ -> IO (Either String Credential) credentialLoadX509Chain certFile chainFiles privateFile = do x509 <- readSignedObject certFile chains <- mapM readSignedObject chainFiles keys <- readKeyFile privateFile case keys of- [] -> return $ Left "no keys found"- (k:_) -> return $ Right (CertificateChain . concat $ x509 : chains, k)+ [] -> return $ Left "no keys found"+ (k : _) -> return $ Right (CertificateChain . concat $ x509 : chains, k) -- | similar to 'credentialLoadX509FromMemory' but also allow -- specifying chain certificates.-credentialLoadX509ChainFromMemory :: ByteString- -> [ByteString]- -> ByteString- -> Either String Credential+credentialLoadX509ChainFromMemory+ :: ByteString+ -> [ByteString]+ -> ByteString+ -> Either String Credential credentialLoadX509ChainFromMemory certData chainData privateData =- let x509 = readSignedObjectFromMemory certData+ let x509 = readSignedObjectFromMemory certData chains = map readSignedObjectFromMemory chainData- keys = readKeyFileFromMemory privateData+ keys = readKeyFileFromMemory privateData in case keys of- [] -> Left "no keys found"- (k:_) -> Right (CertificateChain . concat $ x509 : chains, k)+ [] -> Left "no keys found"+ (k : _) -> Right (CertificateChain . concat $ x509 : chains, k) credentialsListSigningAlgorithms :: Credentials -> [KeyExchangeSignatureAlg] credentialsListSigningAlgorithms (Credentials l) = mapMaybe credentialCanSign l -credentialsFindForSigning :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential+credentialsFindForSigning+ :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential credentialsFindForSigning kxsAlg (Credentials l) = find forSigning l- where forSigning cred = case credentialCanSign cred of- Nothing -> False- Just kxs -> kxs == kxsAlg+ where+ forSigning cred = case credentialCanSign cred of+ Nothing -> False+ Just kxs -> kxs == kxsAlg credentialsFindForDecrypting :: Credentials -> Maybe Credential credentialsFindForDecrypting (Credentials l) = find forEncrypting l- where forEncrypting cred = Just () == credentialCanDecrypt cred+ where+ forEncrypting cred = Just () == credentialCanDecrypt cred -- here we assume that only RSA is supported for key encipherment (encryption/decryption) -- we keep the same construction as 'credentialCanSign', returning a Maybe of () in case@@ -109,69 +115,71 @@ case (pub, priv) of (PubKeyRSA _, PrivKeyRSA _) -> case extensionGet (certExtensions cert) of- Nothing -> Just ()+ Nothing -> Just () Just (ExtKeyUsage flags) | KeyUsage_keyEncipherment `elem` flags -> Just ()- | otherwise -> Nothing- _ -> Nothing- where cert = getCertificate signed- pub = certPubKey cert- signed = getCertificateChainLeaf chain+ | otherwise -> Nothing+ _ -> Nothing+ where+ cert = getCertificate signed+ pub = certPubKey cert+ signed = getCertificateChainLeaf chain credentialCanSign :: Credential -> Maybe KeyExchangeSignatureAlg credentialCanSign (chain, priv) = case extensionGet (certExtensions cert) of- Nothing -> findKeyExchangeSignatureAlg (pub, priv)+ Nothing -> findKeyExchangeSignatureAlg (pub, priv) Just (ExtKeyUsage flags)- | KeyUsage_digitalSignature `elem` flags -> findKeyExchangeSignatureAlg (pub, priv)- | otherwise -> Nothing- where cert = getCertificate signed- pub = certPubKey cert- signed = getCertificateChainLeaf chain+ | KeyUsage_digitalSignature `elem` flags ->+ findKeyExchangeSignatureAlg (pub, priv)+ | otherwise -> Nothing+ where+ cert = getCertificate signed+ pub = certPubKey cert+ signed = getCertificateChainLeaf chain credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey) credentialPublicPrivateKeys (chain, priv) = pub `seq` (pub, priv)- where cert = getCertificate signed- pub = certPubKey cert- signed = getCertificateChainLeaf chain+ where+ cert = getCertificate signed+ pub = certPubKey cert+ signed = getCertificateChainLeaf chain getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm getHashSignature signed = case signedAlg $ getSigned signed of- SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg- SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSS hashAlg- SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg-+ SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg+ SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSA hashAlg+ SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA256) SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA384) SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA512)-- SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519)- SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448)-- _ -> Nothing+ SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519)+ SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448)+ _ -> Nothing where- convertHash sig X509.HashMD5 = Just (TLS.HashMD5 , sig)- convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1 , sig)+ convertHash sig X509.HashMD5 = Just (TLS.HashMD5, sig)+ convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1, sig) convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig) convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig) convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig) convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig)- convertHash _ _ = Nothing+ convertHash _ _ = Nothing -- | Checks whether certificate signatures in the chain comply with a list of -- hash/signature algorithm pairs. Currently the verification applies only to -- the signature of the leaf certificate, and when not self-signed. This may -- be extended to additional chain elements in the future.-credentialMatchesHashSignatures :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool+credentialMatchesHashSignatures+ :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool credentialMatchesHashSignatures hashSigs (chain, _) = case chain of- CertificateChain [] -> True- CertificateChain (leaf:_) -> isSelfSigned leaf || matchHashSig leaf+ CertificateChain [] -> True+ CertificateChain (leaf : _) -> isSelfSigned leaf || matchHashSig leaf where matchHashSig signed = case getHashSignature signed of- Nothing -> False- Just hs -> hs `elem` hashSigs+ Nothing -> False+ Just hs -> hs `elem` hashSigs isSelfSigned signed = let cert = getCertificate signed
Network/TLS/Crypto.hs view
@@ -1,53 +1,52 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}-module Network.TLS.Crypto- ( HashContext- , HashCtx- , hashInit- , hashUpdate- , hashUpdateSSL- , hashFinal+{-# OPTIONS_HADDOCK hide #-} - , module Network.TLS.Crypto.DH- , module Network.TLS.Crypto.IES- , module Network.TLS.Crypto.Types+module Network.TLS.Crypto (+ HashContext,+ HashCtx,+ hashInit,+ hashUpdate,+ hashUpdates,+ hashUpdateSSL,+ hashFinal,+ module Network.TLS.Crypto.DH,+ module Network.TLS.Crypto.IES,+ module Network.TLS.Crypto.Types, -- * Hash- , hash- , Hash(..)- , hashName- , hashDigestSize- , hashBlockSize+ hash,+ hashChunks,+ Hash (..),+ hashName,+ hashDigestSize,+ hashBlockSize, -- * key exchange generic interface- , PubKey(..)- , PrivKey(..)- , PublicKey- , PrivateKey- , SignatureParams(..)- , isKeyExchangeSignatureKey- , findKeyExchangeSignatureAlg- , findFiniteFieldGroup- , findEllipticCurveGroup- , kxEncrypt- , kxDecrypt- , kxSign- , kxVerify- , kxCanUseRSApkcs1- , kxCanUseRSApss- , kxSupportedPrivKeyEC- , KxError(..)- , RSAEncoding(..)- ) where+ PubKey (..),+ PrivKey (..),+ PublicKey,+ PrivateKey,+ SignatureParams (..),+ isKeyExchangeSignatureKey,+ findKeyExchangeSignatureAlg,+ findFiniteFieldGroup,+ findEllipticCurveGroup,+ kxEncrypt,+ kxDecrypt,+ kxSign,+ kxVerify,+ kxCanUseRSApkcs1,+ kxCanUseRSApss,+ kxSupportedPrivKeyEC,+ KxError (..),+ RSAEncoding (..),+) where -import qualified Crypto.Hash as H-import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert)+import qualified Crypto.ECC as ECDSA import Crypto.Error+import qualified Crypto.Hash as H import Crypto.Number.Basic (numBits)-import Crypto.Random-import qualified Crypto.ECC as ECDSA import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA_ECC@@ -58,59 +57,71 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS--import Data.X509 (PrivKey(..), PubKey(..), PrivKeyEC(..), PubKeyEC(..),- SerializedPoint(..))+import Crypto.Random+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 (..),+ PubKey (..),+ PubKeyEC (..),+ 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.Types-import Data.ASN1.Encoding-import Data.ASN1.BinaryEncoding (DER(..), BER(..))--import Data.Proxy+---------------------------------------------------------------- {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-} type PrivateKey = PrivKey -data KxError =- RSAError RSA.Error+data KxError+ = RSAError RSA.Error | KxUnsupported deriving (Show) isKeyExchangeSignatureKey :: KeyExchangeSignatureAlg -> PubKey -> Bool isKeyExchangeSignatureKey = f where- f KX_RSA (PubKeyRSA _) = True- f KX_DSS (PubKeyDSA _) = True- f KX_ECDSA (PubKeyEC _) = True- f KX_ECDSA (PubKeyEd25519 _) = True- f KX_ECDSA (PubKeyEd448 _) = True- f _ _ = False+ f KX_RSA (PubKeyRSA _) = True+ f KX_DSA (PubKeyDSA _) = True+ f KX_ECDSA (PubKeyEC _) = True+ f KX_ECDSA (PubKeyEd25519 _) = True+ f KX_ECDSA (PubKeyEd448 _) = True+ f _ _ = False -findKeyExchangeSignatureAlg :: (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg+findKeyExchangeSignatureAlg+ :: (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg findKeyExchangeSignatureAlg keyPair = case keyPair of- (PubKeyRSA _, PrivKeyRSA _) -> Just KX_RSA- (PubKeyDSA _, PrivKeyDSA _) -> Just KX_DSS- (PubKeyEC _, PrivKeyEC _) -> Just KX_ECDSA- (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just KX_ECDSA- (PubKeyEd448 _, PrivKeyEd448 _) -> Just KX_ECDSA- _ -> Nothing+ (PubKeyRSA _, PrivKeyRSA _) -> Just KX_RSA+ (PubKeyDSA _, PrivKeyDSA _) -> Just KX_DSA+ (PubKeyEC _, PrivKeyEC _) -> Just KX_ECDSA+ (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just KX_ECDSA+ (PubKeyEd448 _, PrivKeyEd448 _) -> Just KX_ECDSA+ _ -> Nothing findFiniteFieldGroup :: DH.Params -> Maybe Group findFiniteFieldGroup params = lookup (pg params) table where pg (DH.Params p g _) = (p, g) - table = [ (pg prms, grp) | grp <- availableFFGroups- , let Just prms = dhParamsForGroup grp- ]+ table =+ [ (pg prms, grp)+ | grp <- availableFFGroups+ , let prms = fromJust $ dhParamsForGroup grp+ ] findEllipticCurveGroup :: PubKeyEC -> Maybe Group findEllipticCurveGroup ecPub =@@ -118,71 +129,76 @@ Just ECC.SEC_p256r1 -> Just P256 Just ECC.SEC_p384r1 -> Just P384 Just ECC.SEC_p521r1 -> Just P521- _ -> Nothing+ _ -> Nothing -- functions to use the hidden class. hashInit :: Hash -> HashContext-hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5)-hashInit SHA1 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA1)-hashInit SHA224 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA224)-hashInit SHA256 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA256)-hashInit SHA384 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA384)-hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512)+hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5)+hashInit SHA1 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA1)+hashInit SHA224 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA224)+hashInit SHA256 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA256)+hashInit SHA384 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA384)+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) -hashUpdateSSL :: HashCtx- -> (B.ByteString,B.ByteString) -- ^ (for the md5 context, for the sha1 context)- -> HashCtx+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+ -> (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) =+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)+ deriving (Show, Eq) -data HashContext =- HashContext ContextSimple+data HashContext+ = HashContext ContextSimple | HashContextSSL (H.Context H.SHA1) (H.Context H.MD5) instance Show HashContext where show _ = "hash-context" -data ContextSimple = forall alg . H.HashAlgorithm alg => ContextSimple (H.Context alg)+data ContextSimple+ = forall alg. H.HashAlgorithm alg => ContextSimple (H.Context alg) 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 -- | Digest size in bytes. hashDigestSize :: Hash -> Int-hashDigestSize MD5 = 16-hashDigestSize SHA1 = 20+hashDigestSize MD5 = 16+hashDigestSize SHA1 = 20 hashDigestSize SHA224 = 28 hashDigestSize SHA256 = 32 hashDigestSize SHA384 = 48@@ -190,8 +206,8 @@ hashDigestSize SHA1_MD5 = 36 hashBlockSize :: Hash -> Int-hashBlockSize MD5 = 64-hashBlockSize SHA1 = 64+hashBlockSize MD5 = 64+hashBlockSize SHA1 = 64 hashBlockSize SHA224 = 64 hashBlockSize SHA256 = 64 hashBlockSize SHA384 = 128@@ -201,18 +217,20 @@ {- key exchange methods encrypt and decrypt for each supported algorithm -} generalizeRSAError :: Either RSA.Error a -> Either KxError a-generalizeRSAError (Left e) = Left (RSAError e)+generalizeRSAError (Left e) = Left (RSAError e) generalizeRSAError (Right x) = Right x -kxEncrypt :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString)+kxEncrypt+ :: MonadRandom r => PublicKey -> ScrubbedBytes -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b-kxEncrypt _ _ = return (Left KxUnsupported)+kxEncrypt _ _ = return (Left KxUnsupported) -kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString)+kxDecrypt+ :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ScrubbedBytes) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b-kxDecrypt _ _ = return (Left KxUnsupported)+kxDecrypt _ _ = return (Left KxUnsupported) -data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq)+data RSAEncoding = RSApkcs1 | RSApss deriving (Show, Eq) -- | Test the RSASSA-PKCS1 length condition described in RFC 8017 section 9.2, -- i.e. @emLen >= tLen + 11@. Lengths are in bytes.@@ -221,13 +239,13 @@ where tLen = prefixSize h + hashDigestSize h - prefixSize MD5 = 18- prefixSize SHA1 = 15+ prefixSize MD5 = 18+ prefixSize SHA1 = 15 prefixSize SHA224 = 19 prefixSize SHA256 = 19 prefixSize SHA384 = 19 prefixSize SHA512 = 19- prefixSize _ = error (show h ++ " is not supported for RSASSA-PKCS1")+ prefixSize _ = error (show h ++ " is not supported for RSASSA-PKCS1") -- | Test the RSASSA-PSS length condition described in RFC 8017 section 9.1.1, -- i.e. @emBits >= 8hLen + 8sLen + 9@. Lengths are in bits.@@ -237,45 +255,45 @@ -- Signature algorithm and associated parameters. -- -- FIXME add RSAPSSParams-data SignatureParams =- RSAParams Hash RSAEncoding- | DSSParams- | ECDSAParams Hash+data SignatureParams+ = RSAParams Hash RSAEncoding+ | DSAParams+ | ECDSAParams Hash | Ed25519Params | Ed448Params- deriving (Show,Eq)+ deriving (Show, Eq) -- Verify that the signature matches the given message, using the -- public key. -- kxVerify :: PublicKey -> SignatureParams -> ByteString -> ByteString -> Bool-kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign-kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign-kxVerify (PubKeyDSA pk) DSSParams msg signBS =-+kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign+kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign+kxVerify (PubKeyDSA pk) DSAParams msg signBS = case dsaToSignature signBS of Just sig -> DSA.verify H.SHA1 pk sig msg- _ -> False+ _ -> False where- dsaToSignature :: ByteString -> Maybe DSA.Signature- dsaToSignature b =- case decodeASN1' BER b of- Left _ -> Nothing- Right asn1 ->- case asn1 of- Start Sequence:IntVal r:IntVal s:End Sequence:_ ->- Just DSA.Signature { DSA.sign_r = r, DSA.sign_s = s }- _ ->- Nothing+ dsaToSignature :: ByteString -> Maybe DSA.Signature+ dsaToSignature b =+ case decodeASN1' BER b of+ Left _ -> Nothing+ Right asn1 ->+ case asn1 of+ Start Sequence : IntVal r : IntVal s : End Sequence : _ ->+ Just DSA.Signature{DSA.sign_r = r, DSA.sign_s = s}+ _ ->+ Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS =- fromMaybe False $ join $- withPubKeyEC key verifyProxy verifyClassic Nothing+ fromMaybe False $+ join $+ withPubKeyEC key verifyProxy verifyClassic Nothing where decodeSignatureASN1 buildRS = case decodeASN1' BER sigBS of- Left _ -> Nothing- Right [Start Sequence,IntVal r,IntVal s,End Sequence] ->+ Left _ -> Nothing+ Right [Start Sequence, IntVal r, IntVal s, End Sequence] -> Just (buildRS r s) Right _ -> Nothing verifyProxy prx pubkey = do@@ -287,145 +305,198 @@ signature <- decodeSignatureASN1 ECDSA_ECC.Signature verifyF <- withAlg ECDSA_ECC.verify return $ verifyF pubkey signature msg- withAlg :: (forall hash . H.HashAlgorithm hash => hash -> a) -> Maybe a+ withAlg :: (forall hash. H.HashAlgorithm hash => hash -> a) -> Maybe a withAlg f = case alg of- MD5 -> Just (f H.MD5)- SHA1 -> Just (f H.SHA1)- SHA224 -> Just (f H.SHA224)- SHA256 -> Just (f H.SHA256)- SHA384 -> Just (f H.SHA384)- SHA512 -> Just (f H.SHA512)- _ -> Nothing+ MD5 -> Just (f H.MD5)+ SHA1 -> Just (f H.SHA1)+ SHA224 -> Just (f H.SHA224)+ SHA256 -> Just (f H.SHA256)+ SHA384 -> Just (f H.SHA384)+ SHA512 -> Just (f H.SHA512)+ _ -> Nothing kxVerify (PubKeyEd25519 key) Ed25519Params msg sigBS = case Ed25519.signature sigBS of CryptoPassed sig -> Ed25519.verify key msg sig- _ -> False+ _ -> False kxVerify (PubKeyEd448 key) Ed448Params msg sigBS = case Ed448.signature sigBS of CryptoPassed sig -> Ed448.verify key msg sig- _ -> False-kxVerify _ _ _ _ = False+ _ -> False+kxVerify _ _ _ _ = False -- Sign the given message using the private key. ---kxSign :: MonadRandom r- => PrivateKey- -> PublicKey- -> SignatureParams- -> ByteString- -> r (Either KxError ByteString)+kxSign+ :: MonadRandom r+ => PrivateKey+ -> PublicKey+ -> SignatureParams+ -> ByteString+ -> r (Either KxError ByteString) kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApkcs1) msg = generalizeRSAError <$> rsaSignHash hashAlg pk msg kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApss) msg = generalizeRSAError <$> rsapssSignHash hashAlg pk msg-kxSign (PrivKeyDSA pk) (PubKeyDSA _) DSSParams msg = do+kxSign (PrivKeyDSA pk) (PubKeyDSA _) DSAParams msg = do sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign)- where dsaSequence sign = [Start Sequence,IntVal (DSA.sign_r sign),IntVal (DSA.sign_s sign),End Sequence]+ where+ dsaSequence sign =+ [ Start Sequence+ , IntVal (DSA.sign_r sign)+ , IntVal (DSA.sign_s sign)+ , End Sequence+ ] kxSign (PrivKeyEC pk) (PubKeyEC _) (ECDSAParams hashAlg) msg = case withPrivKeyEC pk doSign (const unsupported) unsupported of- Nothing -> unsupported+ Nothing -> unsupported Just run -> fmap encode <$> run- where encode (r, s) = encodeASN1' DER- [ Start Sequence, IntVal r, IntVal s, End Sequence ]- doSign prx privkey = do- msig <- ecdsaSignHash prx hashAlg privkey msg- return $ case msig of- Nothing -> Left KxUnsupported- Just sign -> Right (ECDSA.signatureToIntegers prx sign)- unsupported = return $ Left KxUnsupported+ where+ encode (r, s) =+ encodeASN1'+ DER+ [Start Sequence, IntVal r, IntVal s, End Sequence]+ doSign prx privkey = do+ msig <- ecdsaSignHash prx hashAlg privkey msg+ return $ case msig of+ Nothing -> Left KxUnsupported+ 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) -rsaSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString)+rsaSignHash+ :: MonadRandom m+ => Hash+ -> RSA.PrivateKey+ -> ByteString+ -> m (Either RSA.Error ByteString) rsaSignHash SHA1_MD5 pk msg = RSA.signSafer noHash pk msg-rsaSignHash MD5 pk msg = RSA.signSafer (Just H.MD5) pk msg-rsaSignHash SHA1 pk msg = RSA.signSafer (Just H.SHA1) pk msg-rsaSignHash SHA224 pk msg = RSA.signSafer (Just H.SHA224) pk msg-rsaSignHash SHA256 pk msg = RSA.signSafer (Just H.SHA256) pk msg-rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg-rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg+rsaSignHash MD5 pk msg = RSA.signSafer (Just H.MD5) pk msg+rsaSignHash SHA1 pk msg = RSA.signSafer (Just H.SHA1) pk msg+rsaSignHash SHA224 pk msg = RSA.signSafer (Just H.SHA224) pk msg+rsaSignHash SHA256 pk msg = RSA.signSafer (Just H.SHA256) pk msg+rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg+rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg -rsapssSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString)+rsapssSignHash+ :: MonadRandom m+ => Hash+ -> RSA.PrivateKey+ -> ByteString+ -> m (Either RSA.Error ByteString) rsapssSignHash SHA256 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA256) pk msg rsapssSignHash SHA384 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA384) pk msg rsapssSignHash SHA512 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA512) pk msg-rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash"+rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash" rsaVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsaVerifyHash SHA1_MD5 = RSA.verify noHash-rsaVerifyHash MD5 = RSA.verify (Just H.MD5)-rsaVerifyHash SHA1 = RSA.verify (Just H.SHA1)-rsaVerifyHash SHA224 = RSA.verify (Just H.SHA224)-rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256)-rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384)-rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512)+rsaVerifyHash MD5 = RSA.verify (Just H.MD5)+rsaVerifyHash SHA1 = RSA.verify (Just H.SHA1)+rsaVerifyHash SHA224 = RSA.verify (Just H.SHA224)+rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256)+rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384)+rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512) rsapssVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsapssVerifyHash SHA256 = PSS.verify (PSS.defaultPSSParams H.SHA256) rsapssVerifyHash SHA384 = PSS.verify (PSS.defaultPSSParams H.SHA384) rsapssVerifyHash SHA512 = PSS.verify (PSS.defaultPSSParams H.SHA512)-rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash"+rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" noHash :: Maybe H.MD5 noHash = Nothing -ecdsaSignHash :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve)- => proxy curve -> Hash -> ECDSA.Scalar curve -> ByteString -> m (Maybe (ECDSA.Signature curve))-ecdsaSignHash prx SHA1 pk msg = Just <$> ECDSA.sign prx pk H.SHA1 msg-ecdsaSignHash prx SHA224 pk msg = Just <$> ECDSA.sign prx pk H.SHA224 msg-ecdsaSignHash prx SHA256 pk msg = Just <$> ECDSA.sign prx pk H.SHA256 msg-ecdsaSignHash prx SHA384 pk msg = Just <$> ECDSA.sign prx pk H.SHA384 msg-ecdsaSignHash prx SHA512 pk msg = Just <$> ECDSA.sign prx pk H.SHA512 msg-ecdsaSignHash _ _ _ _ = return Nothing+ecdsaSignHash+ :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve)+ => proxy curve+ -> Hash+ -> ECDSA.Scalar curve+ -> ByteString+ -> m (Maybe (ECDSA.Signature curve))+ecdsaSignHash prx SHA1 pk msg = Just <$> ECDSA.sign prx pk H.SHA1 msg+ecdsaSignHash prx SHA224 pk msg = Just <$> ECDSA.sign prx pk H.SHA224 msg+ecdsaSignHash prx SHA256 pk msg = Just <$> ECDSA.sign prx pk H.SHA256 msg+ecdsaSignHash prx SHA384 pk msg = Just <$> ECDSA.sign prx pk H.SHA384 msg+ecdsaSignHash prx SHA512 pk msg = Just <$> ECDSA.sign prx pk H.SHA512 msg+ecdsaSignHash _ _ _ _ = return Nothing -- Currently we generate ECDSA signatures in constant time for P256 only. kxSupportedPrivKeyEC :: PrivKeyEC -> Bool kxSupportedPrivKeyEC privkey = case ecPrivKeyCurveName privkey of Just ECC.SEC_p256r1 -> True- _ -> False+ Just ECC.SEC_p384r1 -> True+ Just ECC.SEC_p521r1 -> True+ _ -> False -- Perform a public-key operation with a parameterized ECC implementation when -- available, otherwise fallback to the classic ECC implementation.-withPubKeyEC :: PubKeyEC- -> (forall curve . ECDSA.EllipticCurveECDSA curve => Proxy curve -> ECDSA.PublicKey curve -> a)- -> (ECDSA_ECC.PublicKey -> a)- -> a- -> Maybe a+withPubKeyEC+ :: PubKeyEC+ -> ( forall curve+ . ECDSA.EllipticCurveECDSA curve+ => Proxy curve+ -> ECDSA.PublicKey curve+ -> a+ )+ -> (ECDSA_ECC.PublicKey -> a)+ -> a+ -> Maybe a withPubKeyEC pubkey withProxy withClassic whenUnknown = case ecPubKeyCurveName pubkey of- Nothing -> Just whenUnknown+ Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> maybeCryptoError $ withProxy p256 <$> ECDSA.decodePublic p256 bs- Just curveName ->+ 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+ pub = unserializePoint curve pt in withClassic . ECDSA_ECC.PublicKey curve <$> pub- where pt@(SerializedPoint bs) = pubkeyEC_pub pubkey+ where+ pt@(SerializedPoint bs) = pubkeyEC_pub pubkey -- Perform a private-key operation with a parameterized ECC implementation when -- available. Calls for an unsupported curve can be prevented with -- kxSupportedEcPrivKey.-withPrivKeyEC :: PrivKeyEC- -> (forall curve . ECDSA.EllipticCurveECDSA curve => Proxy curve -> ECDSA.PrivateKey curve -> a)- -> (ECC.CurveName -> a)- -> a- -> Maybe a+withPrivKeyEC+ :: PrivKeyEC+ -> ( forall curve+ . ECDSA.EllipticCurveECDSA curve+ => Proxy curve+ -> ECDSA.PrivateKey curve+ -> a+ )+ -> (ECC.CurveName -> a)+ -> a+ -> Maybe a withPrivKeyEC privkey withProxy withUnsupported whenUnknown = case ecPrivKeyCurveName privkey of- Nothing -> Just whenUnknown+ Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> -- Private key should rather be stored as bytearray and converted -- using ECDSA.decodePrivate, unfortunately the data type chosen in -- x509 was Integer. maybeCryptoError $ withProxy p256 <$> ECDSA.scalarFromInteger p256 d- Just curveName -> Just $ withUnsupported curveName- where d = privkeyEC_priv privkey+ 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
@@ -1,35 +1,36 @@-module Network.TLS.Crypto.DH- (+module Network.TLS.Crypto.DH ( -- * DH types- DHParams- , DHPublic- , DHPrivate- , DHKey+ DHParams,+ DHPublic,+ DHPrivate,+ DHKey, -- * DH methods- , dhPublic- , dhPrivate- , dhParams- , dhParamsGetP- , dhParamsGetG- , dhParamsGetBits- , dhGenerateKeyPair- , dhGetShared- , dhValid- , dhUnwrap- , dhUnwrapPublic- ) where+ dhPublic,+ dhPrivate,+ dhParams,+ dhParamsGetP,+ dhParamsGetG,+ dhParamsGetBits,+ dhGenerateKeyPair,+ dhGetShared,+ dhValid,+ dhUnwrap,+ dhUnwrapPublic,+) where +import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH-import Crypto.Number.Basic (numBits)-import qualified Data.ByteArray as B-import Network.TLS.RNG+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA -type DHPublic = DH.PublicNumber-type DHPrivate = DH.PrivateNumber-type DHParams = DH.Params-type DHKey = DH.SharedKey+import Network.TLS.RNG +type DHPublic = DH.PublicNumber+type DHPrivate = DH.PrivateNumber+type DHParams = DH.Params+type DHKey = ScrubbedBytes+ dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber @@ -42,16 +43,16 @@ dhGenerateKeyPair :: MonadRandom r => DHParams -> r (DHPrivate, DHPublic) dhGenerateKeyPair params = do priv <- DH.generatePrivate params- let pub = DH.calculatePublic params priv+ let pub = DH.calculatePublic params priv 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) premaster secret in SSL/TLS before version 1.3.- stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb)+ -- for DH(E) pre-main secret in SSL/TLS before version 1.3.+ 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.@@ -60,7 +61,7 @@ dhValid (DH.Params p _ _) y = 1 < y && y < p - 1 dhUnwrap :: DHParams -> DHPublic -> [Integer]-dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p,g,y]+dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p, g, y] dhParamsGetP :: DHParams -> Integer dhParamsGetP (DH.Params p _ _) = p
Network/TLS/Crypto/IES.hs view
@@ -1,67 +1,116 @@--- |+-- | (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- , GroupPrivate- , GroupKey+module Network.TLS.Crypto.IES (+ GroupPublicA,+ GroupPublicB,+ GroupPrivate,+ GroupKey,+ -- * Group methods- , groupGenerateKeyPair- , groupGetPubShared- , groupGetShared- , encodeGroupPublic- , decodeGroupPublic+ groupGenerateKeyPair,+ groupEncapsulate,+ groupDecapsulate,+ groupEncodePublicA,+ groupDecodePublicA,+ groupEncodePublicB,+ groupDecodePublicB,+ -- * Compatibility with 'Network.TLS.Crypto.DH'- , dhParamsForGroup- , dhGroupGenerateKeyPair- , dhGroupGetPubShared- ) where+ dhParamsForGroup,+ dhGroupGenerateKeyPair,+ dhGroupGetPubShared,+) 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 (os2ip,i2ospOf_)+import Network.TLS.Util.Serialization (i2ospOf_, os2ip) -data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1)- | GroupPri_P384 (Scalar Curve_P384R1)- | GroupPri_P521 (Scalar Curve_P521R1)- | GroupPri_X255 (Scalar Curve_X25519)- | GroupPri_X448 (Scalar Curve_X448)- | GroupPri_FFDHE2048 PrivateNumber- | GroupPri_FFDHE3072 PrivateNumber- | GroupPri_FFDHE4096 PrivateNumber- | GroupPri_FFDHE6144 PrivateNumber- | GroupPri_FFDHE8192 PrivateNumber- deriving (Eq, Show)+{- FOURMOLU_DISABLE -}+data GroupPrivate+ = GroupPri_P256 (Scalar Curve_P256R1)+ | GroupPri_P384 (Scalar Curve_P384R1)+ | GroupPri_P521 (Scalar Curve_P521R1)+ | GroupPri_X255 (Scalar Curve_X25519)+ | GroupPri_X448 (Scalar Curve_X448)+ | GroupPri_FFDHE2048 PrivateNumber+ | GroupPri_FFDHE3072 PrivateNumber+ | 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- deriving (Eq, Show)+{- 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 @@ -77,172 +126,385 @@ 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 dhParamsForGroup FFDHE6144 = Just ffdhe6144 dhParamsForGroup FFDHE8192 = Just ffdhe8192-dhParamsForGroup _ = Nothing+dhParamsForGroup _ = Nothing -groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic)-groupGenerateKeyPair P256 =- (GroupPri_P256,GroupPub_P256) `fs` curveGenerateKeyPair p256-groupGenerateKeyPair P384 =- (GroupPri_P384,GroupPub_P384) `fs` curveGenerateKeyPair p384-groupGenerateKeyPair P521 =- (GroupPri_P521,GroupPub_P521) `fs` curveGenerateKeyPair p521+groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublicA)+groupGenerateKeyPair P256 =+ (GroupPri_P256, GroupPubA_P256) `fs` curveGenerateKeyPair p256+groupGenerateKeyPair P384 =+ (GroupPri_P384, GroupPubA_P384) `fs` curveGenerateKeyPair p384+groupGenerateKeyPair 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)+dhGroupGenerateKeyPair+ :: 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) dhGroupGenerateKeyPair FFDHE6144 = addParams ffdhe6144 (gen' ffdhe6144 exp6144) dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192)-dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp)+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)- -> r (KeyPair a)- -> r (GroupPrivate, GroupPublic)+fs+ :: MonadRandom r+ => (Scalar a -> GroupPrivate, Point a -> GroupPublicA)+ -> r (KeyPair a)+ -> r (GroupPrivate, GroupPublicA) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) -gen :: MonadRandom r- => Params+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+ => 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- -> Int- -> r (PrivateNumber, PublicNumber)-gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits+gen'+ :: MonadRandom r+ => DH.Params+ -> Int+ -> r (PrivateNumber, PublicNumber)+gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits -groupGetPubShared :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey))-groupGetPubShared (GroupPub_P256 pub) =- fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub-groupGetPubShared (GroupPub_P384 pub) =- fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub-groupGetPubShared (GroupPub_P521 pub) =- fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub-groupGetPubShared (GroupPub_X255 pub) =- fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub-groupGetPubShared (GroupPub_X448 pub) =- fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub-groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048-groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072-groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096-groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144-groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192+groupEncapsulate+ :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey))+groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub+groupEncapsulate (GroupPubA_P384 pub) = getECDHPubShared GroupPubB_P384 p384 pub+groupEncapsulate (GroupPubA_P521 pub) = getECDHPubShared GroupPubB_P521 p521 pub+groupEncapsulate (GroupPubA_X255 pub) = getECDHPubShared GroupPubB_X255 x25519 pub+groupEncapsulate (GroupPubA_X448 pub) = getECDHPubShared GroupPubB_X448 x448 pub+groupEncapsulate (GroupPubA_FFDHE2048 pub) = getDHPubShared ffdhe2048 exp2048 pub GroupPubB_FFDHE2048+groupEncapsulate (GroupPubA_FFDHE3072 pub) = getDHPubShared ffdhe3072 exp3072 pub GroupPubB_FFDHE3072+groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096+groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144+groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192+groupEncapsulate (GroupPubA_MLKEM512 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM512 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM768 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM768 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM1024 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM1024 ct, convert sec)+groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' x25519 e1+ (k2, c2) <- ML.encapsulate e2+ -- Sec 4.1: Specifically, the order of shares in the concatenation+ -- has been reversed.+ return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1)+groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' p256 e1+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)+groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' p384 e1+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2) -dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey))-dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub-dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub-dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub-dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub-dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub-dhGroupGetPubShared _ _ = return Nothing+dhGroupGetPubShared+ :: 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 :: MonadRandom r- => Params- -> Int- -> PublicNumber- -> (PublicNumber -> GroupPublic)- -> r (Maybe (GroupPublic, GroupKey))-getPubShared 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)+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) -getPubShared' :: MonadRandom r- => Params- -> Int- -> PublicNumber- -> r (Maybe (PublicNumber, SharedKey))-getPubShared' params expBits pub+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+ => DH.Params+ -> Int+ -> PublicNumber+ -> (PublicNumber -> GroupPublicB)+ -> r (Maybe (GroupPublicB, GroupKey))+getDHPubShared params expBits pub pubTag | 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 mypub = DH.calculatePublic params mypri+ DH.SharedKey share = DH.getShared params mypri pub+ return $ Just (pubTag mypub, 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+getDHPubShared'+ :: MonadRandom r+ => DH.Params+ -> Int+ -> PublicNumber+ -> r (Maybe (PublicNumber, GroupKey))+getDHPubShared' params expBits pub+ | not (valid params pub) = return Nothing+ | otherwise = do+ mypri <- generatePriv expBits+ let share = stripLeadingZeros (DH.getShared params mypri pub)+ return $ Just (DH.calculatePublic params mypri, convert share) -calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret-calcShared params pub pri- | valid params pub = Just $ SharedSecret share- | otherwise = Nothing+unwrap :: SharedSecret -> GroupKey+unwrap (ECC.SharedSecret sec) = sec++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+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) premaster secret in SSL/TLS before version 1.3.-stripLeadingZeros :: SharedKey -> B.ScrubbedBytes-stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb+-- for DH(E) pre-main secret in SSL/TLS before version 1.3.+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
@@ -1,23 +1,143 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+ -- | -- Module : Network.TLS.Crypto.Types -- License : BSD-style -- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp> -- Stability : experimental -- Portability : unknown----module Network.TLS.Crypto.Types where+module Network.TLS.Crypto.Types (+ Group (+ Group,+ P256,+ P384,+ P521,+ X25519,+ X448,+ FFDHE2048,+ FFDHE3072,+ FFDHE4096,+ FFDHE6144,+ FFDHE8192,+ MLKEM512,+ MLKEM768,+ MLKEM1024,+ X25519MLKEM768,+ P256MLKEM768,+ P384MLKEM1024+ ),+ availableFFGroups,+ availableECGroups,+ availableHybridGroups,+ supportedNamedGroups,+ supportedNamedGroupsTLS13,+ KeyExchangeSignatureAlg (..),+) where -data Group = P256 | P384 | P521 | X25519 | X448- | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192- deriving (Eq, Show)+import Codec.Serialise+import Data.Word+import GHC.Generics +newtype Group = Group Word16 deriving (Eq, Generic)+instance Serialise Group++{- FOURMOLU_DISABLE -}+pattern P256 :: Group+pattern P256 = Group 23+pattern P384 :: Group+pattern P384 = Group 24+pattern P521 :: Group+pattern P521 = Group 25+pattern X25519 :: Group+pattern X25519 = Group 29+pattern X448 :: Group+pattern X448 = Group 30+pattern FFDHE2048 :: Group+pattern FFDHE2048 = Group 256+pattern FFDHE3072 :: Group+pattern FFDHE3072 = Group 257+pattern FFDHE4096 :: Group+pattern FFDHE4096 = Group 258+pattern FFDHE6144 :: Group+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"+ show P384 = "P384"+ show P521 = "P521"+ show X25519 = "X25519"+ show X448 = "X448"+ show FFDHE2048 = "FFDHE2048"+ show FFDHE3072 = "FFDHE3072"+ 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 -}+ availableFFGroups :: [Group]-availableFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192]+availableFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192] availableECGroups :: [Group]-availableECGroups = [P256,P384,P521,X25519,X448]+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 -- 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).-data KeyExchangeSignatureAlg = KX_RSA | KX_DSS | KX_ECDSA- deriving (Show, Eq)+data KeyExchangeSignatureAlg = KX_RSA | KX_DSA | KX_ECDSA+ deriving (Show, Eq)
Network/TLS/ErrT.hs view
@@ -1,19 +1,13 @@--- |--- Module : Network.TLS.ErrT--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ a simple compat ErrorT and other error stuff {-# LANGUAGE CPP #-}-module Network.TLS.ErrT- ( runErrT- , ErrT- , MonadError(..)- ) where -import Control.Monad.Except (MonadError(..))+-- | A simple compat ErrorT and other error stuff+module Network.TLS.ErrT (+ runErrT,+ ErrT,+ MonadError (..),+) where++import Control.Monad.Except (MonadError (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) runErrT :: ExceptT e m a -> m (Either e a)
+ Network/TLS/Error.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}++module Network.TLS.Error where++import Control.Exception (Exception (..))+import Data.Typeable++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, 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++----------------------------------------------------------------++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,701 +1,1175 @@-{-# LANGUAGE BangPatterns #-}--- |--- Module : Network.TLS.Extension--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ basic extensions are defined in RFC 6066----module Network.TLS.Extension- ( Extension(..)- , supportedExtensions- , definedExtensions- -- all extensions ID supported- , extensionID_ServerName- , extensionID_MaxFragmentLength- , extensionID_SecureRenegotiation- , extensionID_ApplicationLayerProtocolNegotiation- , extensionID_ExtendedMasterSecret- , extensionID_NegotiatedGroups- , extensionID_EcPointFormats- , extensionID_Heartbeat- , extensionID_SignatureAlgorithms- , extensionID_PreSharedKey- , extensionID_EarlyData- , extensionID_SupportedVersions- , extensionID_Cookie- , extensionID_PskKeyExchangeModes- , extensionID_CertificateAuthorities- , extensionID_OidFilters- , extensionID_PostHandshakeAuth- , extensionID_SignatureAlgorithmsCert- , extensionID_KeyShare- , extensionID_QuicTransportParameters- -- all implemented extensions- , ServerNameType(..)- , ServerName(..)- , MaxFragmentLength(..)- , MaxFragmentEnum(..)- , SecureRenegotiation(..)- , ApplicationLayerProtocolNegotiation(..)- , ExtendedMasterSecret(..)- , NegotiatedGroups(..)- , Group(..)- , EcPointFormatsSupported(..)- , EcPointFormat(..)- , SessionTicket(..)- , HeartBeat(..)- , HeartBeatMode(..)- , SignatureAlgorithms(..)- , SignatureAlgorithmsCert(..)- , SupportedVersions(..)- , KeyShare(..)- , KeyShareEntry(..)- , MessageType(..)- , PostHandshakeAuth(..)- , PskKexMode(..)- , PskKeyExchangeModes(..)- , PskIdentity(..)- , PreSharedKey(..)- , EarlyDataIndication(..)- , Cookie(..)- , CertificateAuthorities(..)- ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC--import Network.TLS.Struct ( DistinguishedName- , ExtensionID- , EnumSafe8(..)- , EnumSafe16(..)- , HashAndSignatureAlgorithm )-import Network.TLS.Crypto.Types-import Network.TLS.Types (Version(..), HostName)--import Network.TLS.Wire-import Network.TLS.Imports-import Network.TLS.Packet ( putDNames- , getDNames- , putSignatureHashAlgorithm- , getSignatureHashAlgorithm- , putBinaryVersion- , getBinaryVersion- )------------------------------------------------------------------ central list defined in <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt>-extensionID_ServerName- , extensionID_MaxFragmentLength- , extensionID_ClientCertificateUrl- , extensionID_TrustedCAKeys- , extensionID_TruncatedHMAC- , extensionID_StatusRequest- , extensionID_UserMapping- , extensionID_ClientAuthz- , extensionID_ServerAuthz- , extensionID_CertType- , extensionID_NegotiatedGroups- , extensionID_EcPointFormats- , extensionID_SRP- , extensionID_SignatureAlgorithms- , extensionID_SRTP- , extensionID_Heartbeat- , extensionID_ApplicationLayerProtocolNegotiation- , extensionID_StatusRequestv2- , extensionID_SignedCertificateTimestamp- , extensionID_ClientCertificateType- , extensionID_ServerCertificateType- , extensionID_Padding- , extensionID_EncryptThenMAC- , extensionID_ExtendedMasterSecret- , extensionID_SessionTicket- , extensionID_PreSharedKey- , extensionID_EarlyData- , extensionID_SupportedVersions- , extensionID_Cookie- , extensionID_PskKeyExchangeModes- , extensionID_CertificateAuthorities- , extensionID_OidFilters- , extensionID_PostHandshakeAuth- , extensionID_SignatureAlgorithmsCert- , extensionID_KeyShare- , extensionID_SecureRenegotiation- , extensionID_QuicTransportParameters :: ExtensionID-extensionID_ServerName = 0x0 -- RFC6066-extensionID_MaxFragmentLength = 0x1 -- RFC6066-extensionID_ClientCertificateUrl = 0x2 -- RFC6066-extensionID_TrustedCAKeys = 0x3 -- RFC6066-extensionID_TruncatedHMAC = 0x4 -- RFC6066-extensionID_StatusRequest = 0x5 -- RFC6066-extensionID_UserMapping = 0x6 -- RFC4681-extensionID_ClientAuthz = 0x7 -- RFC5878-extensionID_ServerAuthz = 0x8 -- RFC5878-extensionID_CertType = 0x9 -- RFC6091-extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3-extensionID_EcPointFormats = 0xb -- RFC4492-extensionID_SRP = 0xc -- RFC5054-extensionID_SignatureAlgorithms = 0xd -- RFC5246, TLS 1.3-extensionID_SRTP = 0xe -- RFC5764-extensionID_Heartbeat = 0xf -- RFC6520-extensionID_ApplicationLayerProtocolNegotiation = 0x10 -- RFC7301-extensionID_StatusRequestv2 = 0x11 -- RFC6961-extensionID_SignedCertificateTimestamp = 0x12 -- RFC6962-extensionID_ClientCertificateType = 0x13 -- RFC7250-extensionID_ServerCertificateType = 0x14 -- RFC7250-extensionID_Padding = 0x15 -- draft-agl-tls-padding. expires 2015-03-12-extensionID_EncryptThenMAC = 0x16 -- RFC7366-extensionID_ExtendedMasterSecret = 0x17 -- REF7627-extensionID_SessionTicket = 0x23 -- RFC4507--- Reserved 0x28 -- TLS 1.3-extensionID_PreSharedKey = 0x29 -- TLS 1.3-extensionID_EarlyData = 0x2a -- TLS 1.3-extensionID_SupportedVersions = 0x2b -- TLS 1.3-extensionID_Cookie = 0x2c -- TLS 1.3-extensionID_PskKeyExchangeModes = 0x2d -- TLS 1.3--- Reserved 0x2e -- TLS 1.3-extensionID_CertificateAuthorities = 0x2f -- TLS 1.3-extensionID_OidFilters = 0x30 -- TLS 1.3-extensionID_PostHandshakeAuth = 0x31 -- TLS 1.3-extensionID_SignatureAlgorithmsCert = 0x32 -- TLS 1.3-extensionID_KeyShare = 0x33 -- TLS 1.3-extensionID_QuicTransportParameters = 0x39 -- QUIC-extensionID_SecureRenegotiation = 0xff01 -- RFC5746----------------------------------------------------------------definedExtensions :: [ExtensionID]-definedExtensions =- [ extensionID_ServerName- , extensionID_MaxFragmentLength- , extensionID_ClientCertificateUrl- , extensionID_TrustedCAKeys- , extensionID_TruncatedHMAC- , extensionID_StatusRequest- , extensionID_UserMapping- , extensionID_ClientAuthz- , extensionID_ServerAuthz- , extensionID_CertType- , extensionID_NegotiatedGroups- , extensionID_EcPointFormats- , extensionID_SRP- , extensionID_SignatureAlgorithms- , extensionID_SRTP- , extensionID_Heartbeat- , extensionID_ApplicationLayerProtocolNegotiation- , extensionID_StatusRequestv2- , extensionID_SignedCertificateTimestamp- , extensionID_ClientCertificateType- , extensionID_ServerCertificateType- , extensionID_Padding- , extensionID_EncryptThenMAC- , extensionID_ExtendedMasterSecret- , extensionID_SessionTicket- , extensionID_PreSharedKey- , extensionID_EarlyData- , extensionID_SupportedVersions- , extensionID_Cookie- , extensionID_PskKeyExchangeModes- , extensionID_KeyShare- , extensionID_SignatureAlgorithmsCert- , extensionID_CertificateAuthorities- , extensionID_SecureRenegotiation- , extensionID_QuicTransportParameters- ]---- | all supported extensions by the implementation-supportedExtensions :: [ExtensionID]-supportedExtensions = [ extensionID_ServerName- , extensionID_MaxFragmentLength- , extensionID_ApplicationLayerProtocolNegotiation- , extensionID_ExtendedMasterSecret- , extensionID_SecureRenegotiation- , extensionID_NegotiatedGroups- , extensionID_EcPointFormats- , extensionID_SignatureAlgorithms- , extensionID_SignatureAlgorithmsCert- , extensionID_KeyShare- , extensionID_PreSharedKey- , extensionID_EarlyData- , extensionID_SupportedVersions- , extensionID_Cookie- , extensionID_PskKeyExchangeModes- , extensionID_CertificateAuthorities- , extensionID_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 _ = extensionID_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 _ = extensionID_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 (Maybe ByteString)- deriving (Show,Eq)--instance Extension SecureRenegotiation where- extensionID _ = extensionID_SecureRenegotiation- extensionEncode (SecureRenegotiation cvd svd) =- runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty 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 (Just svd)- MsgTClientHello -> return $ SecureRenegotiation opaque Nothing- _ -> error "extensionDecode: SecureRenegotiation"------------------------------------------------------------------ | Application Layer Protocol Negotiation (ALPN)-newtype ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq)--instance Extension ApplicationLayerProtocolNegotiation where- extensionID _ = extensionID_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 Master Secret-data ExtendedMasterSecret = ExtendedMasterSecret deriving (Show,Eq)--instance Extension ExtendedMasterSecret where- extensionID _ = extensionID_ExtendedMasterSecret- extensionEncode ExtendedMasterSecret = B.empty- extensionDecode MsgTClientHello _ = Just ExtendedMasterSecret- extensionDecode MsgTServerHello _ = Just ExtendedMasterSecret- extensionDecode _ _ = error "extensionDecode: ExtendedMasterSecret"----------------------------------------------------------------newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq)---- on decode, filter all unknown curves-instance Extension NegotiatedGroups where- extensionID _ = extensionID_NegotiatedGroups- extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups- extensionDecode MsgTClientHello = decodeNegotiatedGroups- extensionDecode MsgTEncryptedExtensions = decodeNegotiatedGroups- extensionDecode _ = error "extensionDecode: NegotiatedGroups"--decodeNegotiatedGroups :: ByteString -> Maybe NegotiatedGroups-decodeNegotiatedGroups =- runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16)----------------------------------------------------------------newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq)--data EcPointFormat =- EcPointFormat_Uncompressed- | EcPointFormat_AnsiX962_compressed_prime- | EcPointFormat_AnsiX962_compressed_char2- deriving (Show,Eq)--instance EnumSafe8 EcPointFormat where- fromEnumSafe8 EcPointFormat_Uncompressed = 0- fromEnumSafe8 EcPointFormat_AnsiX962_compressed_prime = 1- fromEnumSafe8 EcPointFormat_AnsiX962_compressed_char2 = 2-- toEnumSafe8 0 = Just EcPointFormat_Uncompressed- toEnumSafe8 1 = Just EcPointFormat_AnsiX962_compressed_prime- toEnumSafe8 2 = Just EcPointFormat_AnsiX962_compressed_char2- toEnumSafe8 _ = Nothing---- on decode, filter all unknown formats-instance Extension EcPointFormatsSupported where- extensionID _ = extensionID_EcPointFormats- extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats- extensionDecode MsgTClientHello = decodeEcPointFormatsSupported- extensionDecode MsgTServerHello = decodeEcPointFormatsSupported- extensionDecode _ = error "extensionDecode: EcPointFormatsSupported"--decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported-decodeEcPointFormatsSupported =- runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8)------------------------------------------------------------------ Fixme: this is incomplete--- newtype SessionTicket = SessionTicket ByteString-data SessionTicket = SessionTicket- deriving (Show,Eq)--instance Extension SessionTicket where- extensionID _ = extensionID_SessionTicket- extensionEncode SessionTicket{} = runPut $ return ()- extensionDecode MsgTClientHello = runGetMaybe (return SessionTicket)- extensionDecode MsgTServerHello = runGetMaybe (return SessionTicket)- extensionDecode _ = error "extensionDecode: SessionTicket"----------------------------------------------------------------newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq)--data HeartBeatMode =- HeartBeat_PeerAllowedToSend- | HeartBeat_PeerNotAllowedToSend- deriving (Show,Eq)--instance EnumSafe8 HeartBeatMode where- fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1- fromEnumSafe8 HeartBeat_PeerNotAllowedToSend = 2-- toEnumSafe8 1 = Just HeartBeat_PeerAllowedToSend- toEnumSafe8 2 = Just HeartBeat_PeerNotAllowedToSend- toEnumSafe8 _ = Nothing--instance Extension HeartBeat where- extensionID _ = extensionID_Heartbeat- extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 mode- extensionDecode MsgTClientHello = decodeHeartBeat- extensionDecode MsgTServerHello = decodeHeartBeat- extensionDecode _ = error "extensionDecode: HeartBeat"--decodeHeartBeat :: ByteString -> Maybe HeartBeat-decodeHeartBeat = runGetMaybe $ do- mm <- toEnumSafe8 <$> getWord8- case mm of- Just m -> return $ HeartBeat m- Nothing -> fail "unknown HeartBeatMode"----------------------------------------------------------------newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq)--instance Extension SignatureAlgorithms where- extensionID _ = extensionID_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 _ = extensionID_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 _ = extensionID_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 _ = extensionID_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 . catMaybes <$> getList len getVer- where- getVer = do- ver <- getBinaryVersion- return (2,ver)- extensionDecode MsgTServerHello = runGetMaybe $ do- mver <- getBinaryVersion- case mver of- Just ver -> return $ SupportedVersionsServerHello ver- Nothing -> fail "extensionDecode: SupportedVersionsServerHello"- extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello"----------------------------------------------------------------data KeyShareEntry = KeyShareEntry {- keyShareEntryGroup :: Group- , keyShareEntryKeyExchange :: ByteString- } deriving (Show,Eq)--getKeyShareEntry :: Get (Int, Maybe KeyShareEntry)-getKeyShareEntry = do- g <- getWord16- l <- fromIntegral <$> getWord16- key <- getBytes l- let !len = l + 4- case toEnumSafe16 g of- Nothing -> return (len, Nothing)- Just grp -> return (len, Just $ KeyShareEntry grp key)--putKeyShareEntry :: KeyShareEntry -> Put-putKeyShareEntry (KeyShareEntry grp key) = do- putWord16 $ fromEnumSafe16 grp- putWord16 $ fromIntegral $ B.length key- putBytes key--data KeyShare =- KeyShareClientHello [KeyShareEntry]- | KeyShareServerHello KeyShareEntry- | KeyShareHRR Group- deriving (Show,Eq)--instance Extension KeyShare where- extensionID _ = extensionID_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 grp) = runPut $ putWord16 $ fromEnumSafe16 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 $ do- mgrp <- toEnumSafe16 <$> getWord16- case mgrp of- Nothing -> fail "decoding KeyShare for HRR"- Just grp -> return $ KeyShareHRR grp- extensionDecode _ = error "extensionDecode: KeyShare"----------------------------------------------------------------data PskKexMode = PSK_KE | PSK_DHE_KE deriving (Eq, Show)--instance EnumSafe8 PskKexMode where- fromEnumSafe8 PSK_KE = 0- fromEnumSafe8 PSK_DHE_KE = 1-- toEnumSafe8 0 = Just PSK_KE- toEnumSafe8 1 = Just PSK_DHE_KE- toEnumSafe8 _ = Nothing--newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode] deriving (Eq, Show)--instance Extension PskKeyExchangeModes where- extensionID _ = extensionID_PskKeyExchangeModes- extensionEncode (PskKeyExchangeModes pkms) = runPut $- putWords8 $ map fromEnumSafe8 pkms- extensionDecode MsgTClientHello = runGetMaybe $- PskKeyExchangeModes . mapMaybe toEnumSafe8 <$> 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 _ = extensionID_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 _ = extensionID_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 _ = extensionID_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 _ = extensionID_CertificateAuthorities- extensionEncode (CertificateAuthorities names) = runPut $- putDNames names- extensionDecode MsgTClientHello =- runGetMaybe (CertificateAuthorities <$> getDNames)- extensionDecode MsgTCertificateRequest =- runGetMaybe (CertificateAuthorities <$> getDNames)- extensionDecode _ = error "extensionDecode: CertificateAuthorities"+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# 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+ extensionDecode :: MessageType -> ByteString -> Maybe a+ extensionEncode :: a -> ByteString++data MessageType+ = MsgTClientHello+ | MsgTServerHello+ | MsgTHelloRetryRequest+ | MsgTEncryptedExtensions+ | MsgTNewSessionTicket+ | MsgTCertificateRequest+ deriving (Eq, Show)++------------------------------------------------------------++-- | 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 = decodeServerName+ extensionDecode MsgTServerHello = decodeServerName+ extensionDecode MsgTEncryptedExtensions = decodeServerName+ extensionDecode _ = error "extensionDecode: ServerName"++decodeServerName :: ByteString -> Maybe ServerName+decodeServerName "" = Just $ ServerName [] -- dirty hack for servers+decodeServerName bs = runGetMaybe decode bs+ where+ decode = do+ len <- fromIntegral <$> getWord16+ ServerName <$> getList len getServerName+ 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++------------------------------------------------------------++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 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"+ 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 _ = error "extensionDecode: HeartBeat"++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 _ = 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 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 _ = error "extensionDecode: SessionTicket"++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 _ = error "extensionDecode: PreShareKey"++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 _ = error "extensionDecode: EarlyDataIndication"++------------------------------------------------------------++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 _ = error "extensionDecode: SupportedVersionsServerHello"++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 _ = error "extensionDecode: Cookie"++------------------------------------------------------------++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 _ = error "extensionDecode: PskKeyExchangeModes"++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 _ = error "extensionDecode: CertificateAuthorities"++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 _ = 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 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 _ = error "extensionDecode: KeyShare"++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 _ = error "extensionDecode: EchOuterExtensions"++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 _ = error "extensionDecode: EncryptedClientHello"++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 _ = error "extensionDecode: SecureRenegotiation"
+ 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.hs view
@@ -1,15 +1,8 @@--- |--- Module : Network.TLS.Extra--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ default values and ciphers-module Network.TLS.Extra- ( module Network.TLS.Extra.Cipher- , module Network.TLS.Extra.FFDHE- ) where+-- | Default values and ciphers+module Network.TLS.Extra (+ module Network.TLS.Extra.Cipher,+ module Network.TLS.Extra.FFDHE,+) where import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE
Network/TLS/Extra/Cipher.hs view
@@ -1,1156 +1,808 @@--- |--- Module : Network.TLS.Extra.Cipher--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Extra.Cipher- (- -- * cipher suite- ciphersuite_default- , ciphersuite_default_det- , ciphersuite_all- , ciphersuite_all_det- , ciphersuite_medium- , ciphersuite_strong- , ciphersuite_strong_det- , ciphersuite_unencrypted- , ciphersuite_dhe_rsa- , ciphersuite_dhe_dss- -- * individual ciphers- , cipher_null_SHA1- , cipher_AES128_SHA1- , cipher_AES256_SHA1- , cipher_AES128_SHA256- , cipher_AES256_SHA256- , cipher_AES128CCM_SHA256- , cipher_AES128CCM8_SHA256- , cipher_AES128GCM_SHA256- , cipher_AES256CCM_SHA256- , cipher_AES256CCM8_SHA256- , cipher_AES256GCM_SHA384- , cipher_DHE_RSA_AES128_SHA1- , cipher_DHE_RSA_AES256_SHA1- , cipher_DHE_RSA_AES128_SHA256- , cipher_DHE_RSA_AES256_SHA256- , cipher_DHE_DSS_AES128_SHA1- , cipher_DHE_DSS_AES256_SHA1- , cipher_DHE_RSA_AES128CCM_SHA256- , cipher_DHE_RSA_AES128CCM8_SHA256- , cipher_DHE_RSA_AES128GCM_SHA256- , cipher_DHE_RSA_AES256CCM_SHA256- , cipher_DHE_RSA_AES256CCM8_SHA256- , cipher_DHE_RSA_AES256GCM_SHA384- , cipher_DHE_RSA_CHACHA20POLY1305_SHA256- , cipher_ECDHE_RSA_AES128GCM_SHA256- , cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_AES128CBC_SHA256- , cipher_ECDHE_RSA_AES128CBC_SHA- , cipher_ECDHE_RSA_AES256CBC_SHA- , cipher_ECDHE_RSA_AES256CBC_SHA384- , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256- , cipher_ECDHE_ECDSA_AES128CBC_SHA- , cipher_ECDHE_ECDSA_AES256CBC_SHA- , cipher_ECDHE_ECDSA_AES128CBC_SHA256- , cipher_ECDHE_ECDSA_AES256CBC_SHA384- , 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- -- * obsolete and non-standard ciphers- , cipher_RSA_3DES_EDE_CBC_SHA1- , cipher_RC4_128_MD5- , cipher_RC4_128_SHA1- , cipher_null_MD5- , cipher_DHE_DSS_RC4_SHA1- ) where--import qualified Data.ByteString as B--import Network.TLS.Types (Version(..))-import Network.TLS.Cipher-import Network.TLS.Imports-import Data.Tuple (swap)--import Crypto.Cipher.AES-import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305-import qualified Crypto.Cipher.RC4 as RC4-import Crypto.Cipher.TripleDES-import Crypto.Cipher.Types hiding (Cipher, cipherName)-import Crypto.Error-import qualified Crypto.MAC.Poly1305 as Poly1305-import Crypto.System.CPU--takelast :: Int -> B.ByteString -> B.ByteString-takelast i b = B.drop (B.length b - i) b--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))--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)--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)--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)--aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD-aes256gcm BulkEncrypt key =- let ctx = noFail (cipherInit key) :: AES256- in (\nonce d ad ->- let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)- in swap $ aeadSimpleEncrypt aeadIni ad d 16)-aes256gcm BulkDecrypt key =- let ctx = noFail (cipherInit key) :: AES256- in (\nonce d ad ->- let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)- in simpleDecrypt aeadIni ad d 16)--simpleDecrypt :: AEAD cipher -> 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--noFail :: CryptoFailable a -> a-noFail = throwCryptoError--makeIV_ :: BlockCipher a => B.ByteString -> IV a-makeIV_ = fromMaybe (error "makeIV_") . makeIV--tripledes_ede :: BulkDirection -> BulkKey -> BulkBlock-tripledes_ede BulkEncrypt key =- let ctx = noFail $ cipherInit key- in (\iv input -> let output = cbcEncrypt ctx (tripledes_iv iv) input in (output, takelast 8 output))-tripledes_ede BulkDecrypt key =- let ctx = noFail $ cipherInit key- in (\iv input -> let output = cbcDecrypt ctx (tripledes_iv iv) input in (output, takelast 8 input))--tripledes_iv :: BulkIV -> IV DES_EDE3-tripledes_iv iv = fromMaybe (error "tripledes cipher iv internal error") $ makeIV iv--rc4 :: BulkDirection -> BulkKey -> BulkStream-rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey)- where- combineRC4 ctx input =- let (ctx', output) = RC4.combine ctx input- in (output, BulkStream (combineRC4 ctx'))--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))--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 cryptonite 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--- AES256, and list each but the weakest of the AES128 ciphers ahead of the--- corresponding AES256 ciphers.------ AEAD ciphers with equivalent security properties are ordered based on CPU--- hardware-acceleration support. If this dynamic runtime behavior is not--- desired, use 'ciphersuite_default_det' instead.-ciphersuite_default :: [Cipher]-ciphersuite_default = sortOptimized sets_default---- | Same as 'ciphersuite_default', but using deterministic preference not--- influenced by the CPU.-ciphersuite_default_det :: [Cipher]-ciphersuite_default_det = sortDeterministic sets_default--sets_default :: [CipherSet]-sets_default =- [ -- First the PFS + GCM + SHA2 ciphers- SetAead- [ cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384 ]- [ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 ]- [ cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256 ]- , SetAead- [ cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384 ]- [ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ]- []- , SetAead- [ cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384 ]- [ cipher_DHE_RSA_CHACHA20POLY1305_SHA256 ]- [ cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256 ]- -- Next the PFS + CBC + SHA2 ciphers- , SetOther- [ 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- ]- -- Next the PFS + CBC + SHA1 ciphers- , SetOther- [ cipher_ECDHE_ECDSA_AES128CBC_SHA, cipher_ECDHE_ECDSA_AES256CBC_SHA- , cipher_ECDHE_RSA_AES128CBC_SHA, cipher_ECDHE_RSA_AES256CBC_SHA- , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1- ]- -- Next the non-PFS + AEAD + SHA2 ciphers- , SetAead- [ cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384 ]- []- [ cipher_AES128CCM_SHA256, cipher_AES256CCM_SHA256 ]- -- Next the non-PFS + CBC + SHA2 ciphers- , SetOther [ cipher_AES256_SHA256, cipher_AES128_SHA256 ]- -- Next the non-PFS + CBC + SHA1 ciphers- , SetOther [ cipher_AES256_SHA1, cipher_AES128_SHA1 ]- -- Nobody uses or should use DSS, RC4, 3DES or MD5--- , SetOther--- [ cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1--- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5--- , cipher_RSA_3DES_EDE_CBC_SHA1--- ]- -- TLS13 (listed at the end but version is negotiated first)- , SetAead- [ cipher_TLS13_AES128GCM_SHA256, cipher_TLS13_AES256GCM_SHA384 ]- [ cipher_TLS13_CHACHA20POLY1305_SHA256 ]- [ cipher_TLS13_AES128CCM_SHA256 ]- ]--{-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-}--- | The default ciphersuites + some not recommended last resort ciphers.------ AEAD ciphers with equivalent security properties are ordered based on CPU--- hardware-acceleration support. If this dynamic runtime behavior is not--- desired, use 'ciphersuite_all_det' instead.-ciphersuite_all :: [Cipher]-ciphersuite_all = ciphersuite_default ++ complement_all--{-# WARNING ciphersuite_all_det "This ciphersuite list contains RC4. Use ciphersuite_strong_det or ciphersuite_default_det instead." #-}--- | Same as 'ciphersuite_all', but using deterministic preference not--- influenced by the CPU.-ciphersuite_all_det :: [Cipher]-ciphersuite_all_det = ciphersuite_default_det ++ complement_all--complement_all :: [Cipher]-complement_all =- [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256, cipher_ECDHE_ECDSA_AES256CCM8_SHA256- , cipher_DHE_RSA_AES128CCM8_SHA256, cipher_DHE_RSA_AES256CCM8_SHA256- , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1- , cipher_AES128CCM8_SHA256, cipher_AES256CCM8_SHA256- , cipher_RSA_3DES_EDE_CBC_SHA1- , cipher_RC4_128_SHA1- , cipher_TLS13_AES128CCM8_SHA256- ]--{-# DEPRECATED ciphersuite_medium "Use ciphersuite_strong or ciphersuite_default instead." #-}--- | list of medium ciphers.-ciphersuite_medium :: [Cipher]-ciphersuite_medium = [ cipher_RC4_128_SHA1- , cipher_AES128_SHA1- ]---- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we--- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305--- variants. For weaker constructs, we use just the AES256 form.------ AEAD ciphers with equivalent security properties are ordered based on CPU--- hardware-acceleration support. If this dynamic runtime behavior is not--- desired, use 'ciphersuite_strong_det' instead.-ciphersuite_strong :: [Cipher]-ciphersuite_strong = sortOptimized sets_strong---- | Same as 'ciphersuite_strong', but using deterministic preference not--- influenced by the CPU.-ciphersuite_strong_det :: [Cipher]-ciphersuite_strong_det = sortDeterministic sets_strong--sets_strong :: [CipherSet]-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 ]- , SetAead [ cipher_ECDHE_ECDSA_AES128GCM_SHA256 ]- []- [ cipher_ECDHE_ECDSA_AES128CCM_SHA256 ]- , SetAead [ cipher_ECDHE_RSA_AES256GCM_SHA384 ]- [ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ]- []- , SetAead [ cipher_ECDHE_RSA_AES128GCM_SHA256 ]- []- []- , SetAead [ cipher_DHE_RSA_AES256GCM_SHA384 ]- [ cipher_DHE_RSA_CHACHA20POLY1305_SHA256 ]- [ cipher_DHE_RSA_AES256CCM_SHA256 ]- , SetAead [ cipher_DHE_RSA_AES128GCM_SHA256 ]- []- [ cipher_DHE_RSA_AES128CCM_SHA256 ]- -- No AEAD- , SetOther- [ cipher_ECDHE_ECDSA_AES256CBC_SHA384- , cipher_ECDHE_RSA_AES256CBC_SHA384- , cipher_DHE_RSA_AES256_SHA256- ]- -- No SHA2- , SetOther- [ cipher_ECDHE_ECDSA_AES256CBC_SHA- , cipher_ECDHE_RSA_AES256CBC_SHA- , cipher_DHE_RSA_AES256_SHA1- ]- -- No PFS- , SetAead [ cipher_AES256GCM_SHA384 ]- []- [ cipher_AES256CCM_SHA256 ]- -- Neither PFS nor AEAD, just SHA2- , SetOther [ cipher_AES256_SHA256 ]- -- Last resort no PFS, AEAD or SHA2- , SetOther [ cipher_AES256_SHA1 ]- -- TLS13 (listed at the end but version is negotiated first)- , SetAead [ cipher_TLS13_AES256GCM_SHA384 ]- [ cipher_TLS13_CHACHA20POLY1305_SHA256 ]- []- , SetAead [ cipher_TLS13_AES128GCM_SHA256 ]- []- [ cipher_TLS13_AES128CCM_SHA256 ]- ]---- | DHE-RSA cipher suite. This only includes ciphers bound specifically to--- DHE-RSA so TLS 1.3 ciphers must be added separately.-ciphersuite_dhe_rsa :: [Cipher]-ciphersuite_dhe_rsa = [ cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES256CCM_SHA256- , cipher_DHE_RSA_CHACHA20POLY1305_SHA256- , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES128CCM_SHA256- , cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256- , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1- ]--ciphersuite_dhe_dss :: [Cipher]-ciphersuite_dhe_dss = [cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1, cipher_DHE_DSS_RC4_SHA1]---- | all unencrypted ciphers, do not use on insecure network.-ciphersuite_unencrypted :: [Cipher]-ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1]--bulk_null, bulk_rc4, bulk_aes128, bulk_aes256, bulk_tripledes_ede, bulk_aes128gcm, bulk_aes256gcm :: Bulk-bulk_aes128ccm, bulk_aes128ccm8, bulk_aes256ccm, bulk_aes256ccm8, bulk_chacha20poly1305 :: Bulk-bulk_null = Bulk- { bulkName = "null"- , bulkKeySize = 0- , bulkIVSize = 0- , bulkExplicitIV = 0- , bulkAuthTagLen = 0- , bulkBlockSize = 0- , bulkF = BulkStreamF passThrough- }- where- passThrough _ _ = BulkStream go where go inp = (inp, BulkStream go)--bulk_rc4 = Bulk- { bulkName = "RC4-128"- , bulkKeySize = 16- , bulkIVSize = 0- , bulkExplicitIV = 0- , bulkAuthTagLen = 0- , bulkBlockSize = 0- , bulkF = BulkStreamF rc4- }--bulk_aes128 = Bulk- { bulkName = "AES128"- , bulkKeySize = 16- , bulkIVSize = 16- , bulkExplicitIV = 0- , bulkAuthTagLen = 0- , bulkBlockSize = 16- , bulkF = BulkBlockF aes128cbc- }--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- { 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- { 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- { 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- { 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- { 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_aes256 = Bulk- { bulkName = "AES256"- , bulkKeySize = 32- , bulkIVSize = 16- , bulkExplicitIV = 0- , bulkAuthTagLen = 0- , bulkBlockSize = 16- , bulkF = BulkBlockF aes256cbc- }--bulk_tripledes_ede = Bulk- { bulkName = "3DES-EDE-CBC"- , bulkKeySize = 24- , bulkIVSize = 8- , bulkExplicitIV = 0- , bulkAuthTagLen = 0- , bulkBlockSize = 8- , bulkF = BulkBlockF tripledes_ede- }--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_aes256gcm_13, bulk_aes128ccm_13, bulk_aes128ccm8_13 :: Bulk-bulk_aes128gcm_13 = bulk_aes128gcm { bulkIVSize = 12, bulkExplicitIV = 0 }-bulk_aes256gcm_13 = bulk_aes256gcm { bulkIVSize = 12, bulkExplicitIV = 0 }-bulk_aes128ccm_13 = bulk_aes128ccm { bulkIVSize = 12, bulkExplicitIV = 0 }-bulk_aes128ccm8_13 = bulk_aes128ccm8 { bulkIVSize = 12, bulkExplicitIV = 0 }---- | unencrypted cipher using RSA for key exchange and MD5 for digest-cipher_null_MD5 :: Cipher-cipher_null_MD5 = Cipher- { cipherID = 0x0001- , cipherName = "RSA-null-MD5"- , cipherBulk = bulk_null- , cipherHash = MD5- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Nothing- }---- | unencrypted cipher using RSA for key exchange and SHA1 for digest-cipher_null_SHA1 :: Cipher-cipher_null_SHA1 = Cipher- { cipherID = 0x0002- , cipherName = "RSA-null-SHA1"- , cipherBulk = bulk_null- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Nothing- }---- | RC4 cipher, RSA key exchange and MD5 for digest-cipher_RC4_128_MD5 :: Cipher-cipher_RC4_128_MD5 = Cipher- { cipherID = 0x0004- , cipherName = "RSA-rc4-128-md5"- , cipherBulk = bulk_rc4- , cipherHash = MD5- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Nothing- }---- | RC4 cipher, RSA key exchange and SHA1 for digest-cipher_RC4_128_SHA1 :: Cipher-cipher_RC4_128_SHA1 = Cipher- { cipherID = 0x0005- , cipherName = "RSA-rc4-128-sha1"- , cipherBulk = bulk_rc4- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Nothing- }---- | 3DES cipher (168 bit key), RSA key exchange and SHA1 for digest-cipher_RSA_3DES_EDE_CBC_SHA1 :: Cipher-cipher_RSA_3DES_EDE_CBC_SHA1 = Cipher- { cipherID = 0x000A- , cipherName = "RSA-3DES-EDE-CBC-SHA1"- , cipherBulk = bulk_tripledes_ede- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Nothing- }---- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest-cipher_AES128_SHA1 :: Cipher-cipher_AES128_SHA1 = Cipher- { cipherID = 0x002F- , cipherName = "RSA-AES128-SHA1"- , cipherBulk = bulk_aes128- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just SSL3- }---- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest-cipher_DHE_DSS_AES128_SHA1 :: Cipher-cipher_DHE_DSS_AES128_SHA1 = Cipher- { cipherID = 0x0032- , cipherName = "DHE-DSA-AES128-SHA1"- , cipherBulk = bulk_aes128- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_DHE_DSS- , cipherMinVer = Nothing- }---- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest-cipher_DHE_RSA_AES128_SHA1 :: Cipher-cipher_DHE_RSA_AES128_SHA1 = Cipher- { cipherID = 0x0033- , cipherName = "DHE-RSA-AES128-SHA1"- , cipherBulk = bulk_aes128- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Nothing- }---- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest-cipher_AES256_SHA1 :: Cipher-cipher_AES256_SHA1 = Cipher- { cipherID = 0x0035- , cipherName = "RSA-AES256-SHA1"- , cipherBulk = bulk_aes256- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just SSL3- }---- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest-cipher_DHE_DSS_AES256_SHA1 :: Cipher-cipher_DHE_DSS_AES256_SHA1 = cipher_DHE_DSS_AES128_SHA1- { cipherID = 0x0038- , cipherName = "DHE-DSA-AES256-SHA1"- , cipherBulk = bulk_aes256- }---- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest-cipher_DHE_RSA_AES256_SHA1 :: Cipher-cipher_DHE_RSA_AES256_SHA1 = cipher_DHE_RSA_AES128_SHA1- { cipherID = 0x0039- , cipherName = "DHE-RSA-AES256-SHA1"- , cipherBulk = bulk_aes256- }---- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest-cipher_AES128_SHA256 :: Cipher-cipher_AES128_SHA256 = Cipher- { cipherID = 0x003C- , cipherName = "RSA-AES128-SHA256"- , cipherBulk = bulk_aes128- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12- }---- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest-cipher_AES256_SHA256 :: Cipher-cipher_AES256_SHA256 = Cipher- { cipherID = 0x003D- , cipherName = "RSA-AES256-SHA256"- , cipherBulk = bulk_aes256- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12- }---- This is not registered in IANA.--- So, this will be removed in the next major release.-cipher_DHE_DSS_RC4_SHA1 :: Cipher-cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1- { cipherID = 0x0066- , cipherName = "DHE-DSA-RC4-SHA1"- , cipherBulk = bulk_rc4- }--cipher_DHE_RSA_AES128_SHA256 :: Cipher-cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1- { cipherID = 0x0067- , cipherName = "DHE-RSA-AES128-SHA256"- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherMinVer = Just TLS12- }--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- }---- | AESCCM cipher (128 bit key), RSA key exchange.--- The SHA256 digest is used as a PRF, not as a MAC.-cipher_AES128CCM_SHA256 :: Cipher-cipher_AES128CCM_SHA256 = Cipher- { cipherID = 0xc09c- , cipherName = "RSA-AES128CCM-SHA256"- , cipherBulk = bulk_aes128ccm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }---- | AESCCM8 cipher (128 bit key), RSA key exchange.--- The SHA256 digest is used as a PRF, not as a MAC.-cipher_AES128CCM8_SHA256 :: Cipher-cipher_AES128CCM8_SHA256 = Cipher- { cipherID = 0xc0a0- , cipherName = "RSA-AES128CCM8-SHA256"- , cipherBulk = bulk_aes128ccm8- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }---- | AESGCM cipher (128 bit key), RSA key exchange.--- The SHA256 digest is used as a PRF, not as a MAC.-cipher_AES128GCM_SHA256 :: Cipher-cipher_AES128GCM_SHA256 = Cipher- { cipherID = 0x009C- , cipherName = "RSA-AES128GCM-SHA256"- , cipherBulk = bulk_aes128gcm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12- }---- | AESCCM cipher (256 bit key), RSA key exchange.--- The SHA256 digest is used as a PRF, not as a MAC.-cipher_AES256CCM_SHA256 :: Cipher-cipher_AES256CCM_SHA256 = Cipher- { cipherID = 0xc09d- , cipherName = "RSA-AES256CCM-SHA256"- , cipherBulk = bulk_aes256ccm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }---- | AESCCM8 cipher (256 bit key), RSA key exchange.--- The SHA256 digest is used as a PRF, not as a MAC.-cipher_AES256CCM8_SHA256 :: Cipher-cipher_AES256CCM8_SHA256 = Cipher- { cipherID = 0xc0a1- , cipherName = "RSA-AES256CCM8-SHA256"- , cipherBulk = bulk_aes256ccm8- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }---- | AESGCM cipher (256 bit key), RSA key exchange.--- The SHA384 digest is used as a PRF, not as a MAC.-cipher_AES256GCM_SHA384 :: Cipher-cipher_AES256GCM_SHA384 = Cipher- { cipherID = 0x009D- , cipherName = "RSA-AES256GCM-SHA384"- , cipherBulk = bulk_aes256gcm- , cipherHash = SHA384- , cipherPRFHash = Just SHA384- , cipherKeyExchange = CipherKeyExchange_RSA- , cipherMinVer = Just TLS12- }--cipher_DHE_RSA_AES128CCM_SHA256 :: Cipher-cipher_DHE_RSA_AES128CCM_SHA256 = Cipher- { cipherID = 0xc09e- , cipherName = "DHE-RSA-AES128CCM-SHA256"- , cipherBulk = bulk_aes128ccm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }--cipher_DHE_RSA_AES128CCM8_SHA256 :: Cipher-cipher_DHE_RSA_AES128CCM8_SHA256 = Cipher- { cipherID = 0xc0a2- , cipherName = "DHE-RSA-AES128CCM8-SHA256"- , cipherBulk = bulk_aes128ccm8- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }--cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher-cipher_DHE_RSA_AES128GCM_SHA256 = Cipher- { cipherID = 0x009E- , cipherName = "DHE-RSA-AES128GCM-SHA256"- , cipherBulk = bulk_aes128gcm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4- }--cipher_DHE_RSA_AES256CCM_SHA256 :: Cipher-cipher_DHE_RSA_AES256CCM_SHA256 = Cipher- { cipherID = 0xc09f- , cipherName = "DHE-RSA-AES256CCM-SHA256"- , cipherBulk = bulk_aes256ccm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }--cipher_DHE_RSA_AES256CCM8_SHA256 :: Cipher-cipher_DHE_RSA_AES256CCM8_SHA256 = Cipher- { cipherID = 0xc0a3- , cipherName = "DHE-RSA-AES256CCM8-SHA256"- , cipherBulk = bulk_aes256ccm8- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3- }--cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher-cipher_DHE_RSA_AES256GCM_SHA384 = Cipher- { cipherID = 0x009F- , cipherName = "DHE-RSA-AES256GCM-SHA384"- , cipherBulk = bulk_aes256gcm- , cipherHash = SHA384- , cipherPRFHash = Just SHA384- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12- }--cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher-cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = Cipher- { cipherID = 0xCCA8- , cipherName = "ECDHE-RSA-CHACHA20POLY1305-SHA256"- , cipherBulk = bulk_chacha20poly1305- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA- , cipherMinVer = Just TLS12- }--cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher-cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = Cipher- { cipherID = 0xCCA9- , cipherName = "ECDHE-ECDSA-CHACHA20POLY1305-SHA256"- , cipherBulk = bulk_chacha20poly1305- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12- }--cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher-cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = Cipher- { cipherID = 0xCCAA- , cipherName = "DHE-RSA-CHACHA20POLY1305-SHA256"- , cipherBulk = bulk_chacha20poly1305- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_DHE_RSA- , cipherMinVer = Just TLS12- }--cipher_TLS13_AES128GCM_SHA256 :: Cipher-cipher_TLS13_AES128GCM_SHA256 = Cipher- { cipherID = 0x1301- , cipherName = "AES128GCM-SHA256"- , cipherBulk = bulk_aes128gcm_13- , cipherHash = SHA256- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_TLS13- , cipherMinVer = Just TLS13- }--cipher_TLS13_AES256GCM_SHA384 :: Cipher-cipher_TLS13_AES256GCM_SHA384 = Cipher- { cipherID = 0x1302- , cipherName = "AES256GCM-SHA384"- , cipherBulk = bulk_aes256gcm_13- , cipherHash = SHA384- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_TLS13- , cipherMinVer = Just TLS13- }--cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher-cipher_TLS13_CHACHA20POLY1305_SHA256 = Cipher- { cipherID = 0x1303- , cipherName = "CHACHA20POLY1305-SHA256"- , cipherBulk = bulk_chacha20poly1305- , cipherHash = SHA256- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_TLS13- , cipherMinVer = Just TLS13- }--cipher_TLS13_AES128CCM_SHA256 :: Cipher-cipher_TLS13_AES128CCM_SHA256 = Cipher- { cipherID = 0x1304- , cipherName = "AES128CCM-SHA256"- , cipherBulk = bulk_aes128ccm_13- , cipherHash = SHA256- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_TLS13- , cipherMinVer = Just TLS13- }--cipher_TLS13_AES128CCM8_SHA256 :: Cipher-cipher_TLS13_AES128CCM8_SHA256 = Cipher- { cipherID = 0x1305- , cipherName = "AES128CCM8-SHA256"- , cipherBulk = bulk_aes128ccm8_13- , cipherHash = SHA256- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_TLS13- , cipherMinVer = Just TLS13- }--cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher-cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher- { cipherID = 0xC009- , cipherName = "ECDHE-ECDSA-AES128CBC-SHA"- , cipherBulk = bulk_aes128- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS10- }--cipher_ECDHE_ECDSA_AES256CBC_SHA :: Cipher-cipher_ECDHE_ECDSA_AES256CBC_SHA = Cipher- { cipherID = 0xC00A- , cipherName = "ECDHE-ECDSA-AES256CBC-SHA"- , cipherBulk = bulk_aes256- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS10- }--cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher-cipher_ECDHE_RSA_AES128CBC_SHA = Cipher- { cipherID = 0xC013- , cipherName = "ECDHE-RSA-AES128CBC-SHA"- , cipherBulk = bulk_aes128- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA- , cipherMinVer = Just TLS10- }--cipher_ECDHE_RSA_AES256CBC_SHA :: Cipher-cipher_ECDHE_RSA_AES256CBC_SHA = Cipher- { cipherID = 0xC014- , cipherName = "ECDHE-RSA-AES256CBC-SHA"- , cipherBulk = bulk_aes256- , cipherHash = SHA1- , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA- , cipherMinVer = Just TLS10- }--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- }--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- }--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- }--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- }--cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES128CCM_SHA256 = Cipher- { cipherID = 0xc0ac- , cipherName = "ECDHE-ECDSA-AES128CCM-SHA256"- , cipherBulk = bulk_aes128ccm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12 -- RFC 7251- }--cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = Cipher- { cipherID = 0xc0ae- , cipherName = "ECDHE-ECDSA-AES128CCM8-SHA256"- , cipherBulk = bulk_aes128ccm8- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12 -- RFC 7251- }--cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher- { cipherID = 0xC02B- , cipherName = "ECDHE-ECDSA-AES128GCM-SHA256"- , cipherBulk = bulk_aes128gcm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12 -- RFC 5289- }--cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES256CCM_SHA256 = Cipher- { cipherID = 0xc0ad- , cipherName = "ECDHE-ECDSA-AES256CCM-SHA256"- , cipherBulk = bulk_aes256ccm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12 -- RFC 7251- }--cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher-cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = Cipher- { cipherID = 0xc0af- , cipherName = "ECDHE-ECDSA-AES256CCM8-SHA256"- , cipherBulk = bulk_aes256ccm8- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12 -- RFC 7251- }--cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher-cipher_ECDHE_ECDSA_AES256GCM_SHA384 = Cipher- { cipherID = 0xC02C- , cipherName = "ECDHE-ECDSA-AES256GCM-SHA384"- , cipherBulk = bulk_aes256gcm- , cipherHash = SHA384- , cipherPRFHash = Just SHA384- , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA- , cipherMinVer = Just TLS12 -- RFC 5289- }--cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher-cipher_ECDHE_RSA_AES128GCM_SHA256 = Cipher- { cipherID = 0xC02F- , cipherName = "ECDHE-RSA-AES128GCM-SHA256"- , cipherBulk = bulk_aes128gcm- , cipherHash = SHA256- , cipherPRFHash = Just SHA256- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA- , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4- }--cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher-cipher_ECDHE_RSA_AES256GCM_SHA384 = Cipher- { cipherID = 0xC030- , cipherName = "ECDHE-RSA-AES256GCM-SHA384"- , cipherBulk = bulk_aes256gcm- , cipherHash = SHA384- , cipherPRFHash = Just SHA384- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA- , cipherMinVer = Just TLS12 -- RFC 5289- }---- A list of cipher suite is found from:--- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4+module Network.TLS.Extra.Cipher (+ -- * Cipher suite+ ciphersuite_default,+ ciphersuite_default_det,+ ciphersuite_all,+ ciphersuite_all_det,+ ciphersuite_strong,+ ciphersuite_strong_det,+ ciphersuite_dhe_rsa,++ -- * Individual ciphers++ -- ** RFC 5288+ cipher_DHE_RSA_WITH_AES_128_GCM_SHA256,+ cipher_DHE_RSA_WITH_AES_256_GCM_SHA384,++ -- ** 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,++ -- ** 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,++ -- ** RFC 7905+ cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256,+ cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256,+ cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256,++ -- * Deprecated names++ -- ** RFC 5288+ cipher_DHE_RSA_AES128GCM_SHA256,+ cipher_DHE_RSA_AES256GCM_SHA384,++ -- ** RFC 8446+ cipher_TLS13_AES128GCM_SHA256,+ cipher_TLS13_AES256GCM_SHA384,+ cipher_TLS13_CHACHA20POLY1305_SHA256,+ cipher_TLS13_AES128CCM_SHA256,+ cipher_TLS13_AES128CCM8_SHA256,++ -- ** RFC 5289+ cipher_ECDHE_ECDSA_AES128GCM_SHA256,+ cipher_ECDHE_ECDSA_AES256GCM_SHA384,+ cipher_ECDHE_RSA_AES128GCM_SHA256,+ cipher_ECDHE_RSA_AES256GCM_SHA384,++ -- ** RFC 7251+ cipher_ECDHE_ECDSA_AES128CCM_SHA256,+ cipher_ECDHE_ECDSA_AES256CCM_SHA256,+ cipher_ECDHE_ECDSA_AES128CCM8_SHA256,+ cipher_ECDHE_ECDSA_AES256CCM8_SHA256,++ -- ** RFC 7905+ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256,+ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256,+ cipher_DHE_RSA_CHACHA20POLY1305_SHA256,+) where++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+import qualified Data.ByteString as B+import Data.Tuple (swap)++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types++----------------------------------------------------------------++-- | 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+-- AES256, and list each but the weakest of the AES128 ciphers ahead of the+-- corresponding AES256 ciphers.+--+-- AEAD ciphers with equivalent security properties are ordered based on CPU+-- hardware-acceleration support. If this dynamic runtime behavior is not+-- desired, use 'ciphersuite_default_det' instead.+ciphersuite_default :: [Cipher]+ciphersuite_default = ciphersuite_strong++-- | Same as 'ciphersuite_default', but using deterministic preference not+-- influenced by the CPU.+ciphersuite_default_det :: [Cipher]+ciphersuite_default_det = ciphersuite_strong_det++----------------------------------------------------------------++-- | The default ciphersuites + some not recommended last resort ciphers.+--+-- AEAD ciphers with equivalent security properties are ordered based on CPU+-- hardware-acceleration support. If this dynamic runtime behavior is not+-- desired, use 'ciphersuite_all_det' instead.+ciphersuite_all :: [Cipher]+ciphersuite_all = ciphersuite_default ++ complement_all++-- | Same as 'ciphersuite_all', but using deterministic preference not+-- influenced by the CPU.+ciphersuite_all_det :: [Cipher]+ciphersuite_all_det = ciphersuite_default_det ++ complement_all++complement_all :: [Cipher]+complement_all =+ [ 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+-- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305+-- variants. For weaker constructs, we use just the AES256 form.+--+-- AEAD ciphers with equivalent security properties are ordered based on CPU+-- hardware-acceleration support. If this dynamic runtime behavior is not+-- desired, use 'ciphersuite_strong_det' instead.+ciphersuite_strong :: [Cipher]+ciphersuite_strong = sortOptimized sets_strong++-- | Same as 'ciphersuite_strong', but using deterministic preference not+-- influenced by the CPU.+ciphersuite_strong_det :: [Cipher]+ciphersuite_strong_det = sortDeterministic sets_strong++sets_strong :: [CipherSet]+sets_strong =+ [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256+ SetAead+ [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_WITH_AES_128_GCM_SHA256]+ []+ [cipher_ECDHE_ECDSA_WITH_AES_128_CCM]+ , SetAead+ [cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384]+ [cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256]+ []+ , SetAead+ [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256]+ []+ []+ , -- TLS13 (listed at the end but version is negotiated first)+ SetAead+ [cipher13_AES_256_GCM_SHA384]+ [cipher13_CHACHA20_POLY1305_SHA256]+ []+ , SetAead+ [cipher13_AES_128_GCM_SHA256]+ []+ [cipher13_AES_128_CCM_SHA256]+ ]++-- | 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+ ]++----------------------------------------------------------------+----------------------------------------------------------------++-- A list of cipher suite is found from:+-- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4++----------------------------------------------------------------+-- RFC 5288++-- 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+ }++{-# 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++-- 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+ }++{-# 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++-- 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"+ , cipherBulk = bulk_aes128gcm_13+ , cipherHash = SHA256+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }++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"+ , cipherBulk = bulk_aes256gcm_13+ , cipherHash = SHA384+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }++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"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }++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"+ , cipherBulk = bulk_aes128ccm_13+ , cipherHash = SHA256+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }++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"+ , cipherBulk = bulk_aes128ccm8_13+ , cipherHash = SHA256+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , 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++-- 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"+ , cipherBulk = bulk_aes128gcm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++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"+ , cipherBulk = bulk_aes256gcm+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++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"+ , cipherBulk = bulk_aes128gcm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++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"+ , cipherBulk = bulk_aes256gcm+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , 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++-- 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"+ , cipherBulk = bulk_aes128ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251+ }++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"+ , cipherBulk = bulk_aes256ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251+ }++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"+ , cipherBulk = bulk_aes128ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251+ }++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"+ , cipherBulk = bulk_aes256ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , 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++-- 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"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12+ }++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"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , 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+ )++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+ )++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+ )++aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD+aes256gcm BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \nonce d ad ->+ let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 16+ )+aes256gcm BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \nonce d ad ->+ let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)+ in simpleDecrypt aeadIni ad d 16+ )++simpleDecrypt+ :: AEAD cipher -> ByteString -> ByteString -> Int -> (ByteString, AuthTag)+simpleDecrypt aeadIni header input taglen = (output, tag)+ where+ aead = aeadAppendHeader aeadIni header+ (output, aeadFinal) = aeadDecrypt aead input+ tag = aeadFinalize aeadFinal taglen++noFail :: CryptoFailable a -> a+noFail = throwCryptoError++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)+ )++----------------------------------------------------------------++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/Extra/FFDHE.hs view
@@ -15,48 +15,58 @@ -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 103 bits. ffdhe2048 :: DHParams-ffdhe2048 = Params {- params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B423861285C97FFFFFFFFFFFFFFFF- , params_g = 2- , params_bits = 2048- }+ffdhe2048 =+ Params+ { params_p =+ 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B423861285C97FFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 2048+ } -- | 3072 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 125 bits. ffdhe3072 :: DHParams-ffdhe3072 = Params {- params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B66C62E37FFFFFFFFFFFFFFFF- , params_g = 2- , params_bits = 3072- }+ffdhe3072 =+ Params+ { params_p =+ 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B66C62E37FFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 3072+ } -- | 4096 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 150 bits. ffdhe4096 :: DHParams-ffdhe4096 = Params {- params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E655F6AFFFFFFFFFFFFFFFF- , params_g = 2- , params_bits = 4096- }+ffdhe4096 =+ Params+ { params_p =+ 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E655F6AFFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 4096+ } -- | 6144 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 175 bits. ffdhe6144 :: DHParams-ffdhe6144 = Params {- params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CD0E40E65FFFFFFFFFFFFFFFF- , params_g = 2- , params_bits = 6144- }+ffdhe6144 =+ Params+ { params_p =+ 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CD0E40E65FFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 6144+ } -- | 8192 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 192 bits. ffdhe8192 :: DHParams-ffdhe8192 = Params {- params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CCFF46AAA36AD004CF600C8381E425A31D951AE64FDB23FCEC9509D43687FEB69EDD1CC5E0B8CC3BDF64B10EF86B63142A3AB8829555B2F747C932665CB2C0F1CC01BD70229388839D2AF05E454504AC78B7582822846C0BA35C35F5C59160CC046FD8251541FC68C9C86B022BB7099876A460E7451A8A93109703FEE1C217E6C3826E52C51AA691E0E423CFC99E9E31650C1217B624816CDAD9A95F9D5B8019488D9C0A0A1FE3075A577E23183F81D4A3F2FA4571EFC8CE0BA8A4FE8B6855DFE72B0A66EDED2FBABFBE58A30FAFABE1C5D71A87E2F741EF8C1FE86FEA6BBFDE530677F0D97D11D49F7A8443D0822E506A9F4614E011E2A94838FF88CD68C8BB7C5C6424CFFFFFFFFFFFFFFFF- , params_g = 2- , params_bits = 8192- }+ffdhe8192 =+ Params+ { params_p =+ 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CCFF46AAA36AD004CF600C8381E425A31D951AE64FDB23FCEC9509D43687FEB69EDD1CC5E0B8CC3BDF64B10EF86B63142A3AB8829555B2F747C932665CB2C0F1CC01BD70229388839D2AF05E454504AC78B7582822846C0BA35C35F5C59160CC046FD8251541FC68C9C86B022BB7099876A460E7451A8A93109703FEE1C217E6C3826E52C51AA691E0E423CFC99E9E31650C1217B624816CDAD9A95F9D5B8019488D9C0A0A1FE3075A577E23183F81D4A3F2FA4571EFC8CE0BA8A4FE8B6855DFE72B0A66EDED2FBABFBE58A30FAFABE1C5D71A87E2F741EF8C1FE86FEA6BBFDE530677F0D97D11D49F7A8443D0822E506A9F4614E011E2A94838FF88CD68C8BB7C5C6424CFFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 8192+ }
Network/TLS/Handshake.hs view
@@ -1,38 +1,33 @@--- |--- Module : Network.TLS.Handshake--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake- ( handshake- , handshakeWith- , handshakeClientWith- , handshakeServerWith- , handshakeClient- , handshakeServer- ) where+module Network.TLS.Handshake (+ handshake_,+ handshakeWith,+ handshakeClientWith,+ handshakeServerWith,+ handshakeClient,+ handshakeServer,+) where import Network.TLS.Context.Internal-import Network.TLS.Struct--import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client+import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.Struct import Control.Monad.State.Strict --- | Handshake for a new TLS connection--- This is to be called at the beginning of a connection, and during renegotiation-handshake :: MonadIO m => Context -> m ()-handshake ctx =- liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx)+handshake_ :: MonadIO m => Context -> m ()+handshake_ ctx =+ liftIO $+ withRWLock ctx $+ handleException ctx (doHandshake_ (ctxRoleParams ctx) ctx) -- Handshake when requested by the remote end -- 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 =- liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoHandshakeWith ctx ctx hs+handshakeWith :: MonadIO m => Context -> HandshakeR -> m ()+handshakeWith ctx hsr =+ liftIO $+ withWriteLock ctx $+ handleException ctx $+ doHandshakeWith_ (ctxRoleParams ctx) ctx hsr
Network/TLS/Handshake/Certificate.hs view
@@ -1,56 +1,71 @@--- |--- Module : Network.TLS.Handshake.Certificate--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.Certificate- ( certificateRejected- , badCertificate- , rejectOnException- , verifyLeafKeyUsage- , extractCAname- ) where+module Network.TLS.Handshake.Certificate (+ certificateRejected,+ badCertificate,+ rejectOnException,+ verifyLeafKeyUsage,+ verifyLeafKeyUsagePurpose,+ extractCAname,+) where +import Control.Exception (SomeException)+import Control.Monad (unless)+import Control.Monad.State.Strict+import Data.X509 (+ ExtExtendedKeyUsage (..),+ ExtKeyUsage (..),+ ExtKeyUsageFlag,+ ExtKeyUsagePurpose (..),+ extensionGet,+ )+ import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509-import Control.Monad (unless)-import Control.Monad.State.Strict-import Control.Exception (SomeException)-import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet) -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a certificateRejected CertificateRejectRevoked =- throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked)+ throwCore $ Error_Protocol "certificate is revoked" CertificateRevoked certificateRejected CertificateRejectExpired =- throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired)+ throwCore $ Error_Protocol "certificate has expired" CertificateExpired certificateRejected CertificateRejectUnknownCA =- throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa)+ throwCore $ Error_Protocol "certificate has unknown CA" UnknownCa certificateRejected CertificateRejectAbsent =- throwCore $ Error_Protocol ("certificate is missing", True, CertificateRequired)+ throwCore $ Error_Protocol "certificate is missing" CertificateRequired certificateRejected (CertificateRejectOther s) =- throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown)+ throwCore $ Error_Protocol ("certificate rejected: " ++ s) CertificateUnknown badCertificate :: MonadIO m => String -> m a-badCertificate msg = throwCore $ Error_Protocol (msg, True, BadCertificate)+badCertificate msg = throwCore $ Error_Protocol msg BadCertificate rejectOnException :: SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m ()-verifyLeafKeyUsage _ (CertificateChain []) = return ()-verifyLeafKeyUsage validFlags (CertificateChain (signed:_)) =- unless verified $ badCertificate $- "certificate is not allowed for any of " ++ show validFlags+verifyLeafKeyUsage _ (CertificateChain []) = return ()+verifyLeafKeyUsage validFlags (CertificateChain (signed : _)) =+ unless verified $+ badCertificate $+ "certificate is not allowed for any of " ++ show validFlags where- cert = getCertificate signed+ cert = getCertificate signed verified = case extensionGet (certExtensions cert) of- Nothing -> True -- unrestricted cert- Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags+ 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,1099 +1,177 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--- |--- Module : Network.TLS.Handshake.Client--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.Client- ( handshakeClient- , handshakeClientWith- , postHandshakeAuthClientWith- ) where--import Network.TLS.Crypto-import Network.TLS.Context.Internal-import Network.TLS.Parameters-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Credentials-import Network.TLS.Packet hiding (getExtensions)-import Network.TLS.ErrT-import Network.TLS.Extension-import Network.TLS.IO-import Network.TLS.Imports-import Network.TLS.State-import Network.TLS.Measurement-import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_)-import Network.TLS.Types-import Network.TLS.X509-import qualified Data.ByteString as B-import Data.X509 (ExtKeyUsageFlag(..))--import Control.Monad.State.Strict-import Control.Exception (SomeException, bracket)--import Network.TLS.Handshake.Certificate-import Network.TLS.Handshake.Common-import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Control-import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.Signature-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Wire--handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()-handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx-handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure)---- client part of handshake. send a bunch of handshake of client--- values intertwined with response from the server.-handshakeClient :: ClientParams -> Context -> IO ()-handshakeClient cparams ctx = do- let groups = case clientWantSessionResume cparams of- Nothing -> groupsSupported- Just (_, sdata) -> case sessionGroup sdata of- Nothing -> [] -- TLS 1.2 or earlier- Just grp -> grp : filter (/= grp) groupsSupported- groupsSupported = supportedGroups (ctxSupported ctx)- handshakeClient' cparams ctx groups Nothing---- https://tools.ietf.org/html/rfc8446#section-4.1.2 says:--- "The client will also send a--- ClientHello when the server has responded to its ClientHello with a--- HelloRetryRequest. In that case, the client MUST send the same--- ClientHello without modification, except as follows:"------ So, the ClientRandom in the first client hello is necessary.-handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO ()-handshakeClient' cparams ctx groups mparams = do- updateMeasure ctx incrementNbHandshakes- (crand, clientSession) <- generateClientHelloParams- (rtt0, sentExtensions) <- sendClientHello clientSession crand- recvServerHello clientSession sentExtensions- ver <- usingState_ ctx getVersion- unless (maybe True (\(_, _, v) -> v == ver) mparams) $- throwCore $ Error_Protocol ("version changed after hello retry", True, 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- if ver == TLS13 then- if hrr then case drop 1 groups of- [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter)- groups' -> do- when (isJust mparams) $- throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage)- mks <- usingState_ ctx getTLS13KeyShare- case mks of- Just (KeyShareHRR selectedGroup)- | selectedGroup `elem` groups' -> do- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- clearTxState ctx- let cparams' = cparams { clientEarlyData = Nothing }- runPacketFlight ctx $ sendChangeCipherSpec13 ctx- handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))- | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter)- Just _ -> error "handshakeClient': invalid KeyShare value"- Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure)- else- handshakeClient13 cparams ctx groupToSend- else do- when rtt0 $- throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure)- sessionResuming <- usingState_ ctx isSessionResuming- if sessionResuming- then sendChangeCipherAndFinish ctx ClientRole- else do sendClientData cparams ctx- sendChangeCipherAndFinish ctx ClientRole- recvChangeCipherAndFinish ctx- handshakeTerminate ctx- where ciphers = supportedCiphers $ ctxSupported ctx- compressions = supportedCompressions $ ctxSupported ctx- highestVer = maximum $ supportedVersions $ ctxSupported ctx- tls13 = highestVer >= TLS13- ems = supportedExtendedMasterSec $ 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- -- are allergic to an extension with empty data at final position.- --- -- Without TLS 1.3, the list ends with extension "signature_algorithms"- -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions- -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key"- -- (not always present) have length > 0.- getExtensions pskInfo rtt0 = sequence- [ sniExtension- , secureReneg- , alpnExtension- , emsExtension- , groupExtension- , ecPointExtension- --, sessionTicketExtension- , signatureAlgExtension- --, heartbeatExtension- , versionExtension- , earlyDataExtension rtt0- , keyshareExtension- , cookieExtension- , postHandshakeAuthExtension- , pskExchangeModeExtension- , preSharedKeyExtension pskInfo -- MUST be last (RFC 8446)- ]-- toExtensionRaw :: Extension e => e -> ExtensionRaw- toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext)-- secureReneg =- if supportedSecureRenegotiation $ ctxSupported ctx- then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing- 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 ExtendedMasterSecret- sniExtension = if clientUseServerNameIndication cparams- then do let sni = fst $ clientServerIdentification cparams- usingState_ ctx $ setClientSNI sni- return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni]- else return Nothing-- groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx)- ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]- --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]- --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend- --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket-- signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams-- versionExtension- | tls13 = do- let vers = filter (>= TLS10) $ supportedVersions $ ctxSupported ctx- return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers- | otherwise = return Nothing-- -- FIXME- keyshareExtension- | tls13 = case groupToSend of- Nothing -> return Nothing- Just grp -> do- (cpri, ent) <- makeClientKeyShare ctx grp- usingHState ctx $ setGroupPrivate cpri- return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]- | otherwise = return Nothing-- sessionAndCipherToResume13 = do- guard tls13- (sid, sdata) <- clientWantSessionResume cparams- guard (sessionVersion sdata >= TLS13)- sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers- return (sid, sdata, sCipher)-- getPskInfo =- case sessionAndCipherToResume13 of- Nothing -> return Nothing- Just (sid, sdata, sCipher) -> do- let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata- age <- getAge tinfo- return $ if isAgeValid age tinfo- then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo)- else Nothing-- preSharedKeyExtension pskInfo =- case pskInfo of- Nothing -> return Nothing- Just (sid, _, choice, obfAge) ->- let zero = cZero choice- identity = PskIdentity sid obfAge- offeredPsks = PreSharedKeyClientHello [identity] [zero]- in return $ Just $ toExtensionRaw offeredPsks-- pskExchangeModeExtension- | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]- | otherwise = return Nothing-- earlyDataExtension rtt0- | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)- | otherwise = return Nothing-- cookieExtension = do- mcookie <- usingState_ ctx getTLS13Cookie- case mcookie of- Nothing -> return Nothing- Just cookie -> return $ Just $ toExtensionRaw cookie-- postHandshakeAuthExtension- | ctxQUICMode ctx = return Nothing- | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth- | otherwise = return Nothing-- adjustExtentions pskInfo exts ch =- case pskInfo of- Nothing -> return exts- Just (_, sdata, choice, _) -> do- let psk = sessionSecret sdata- earlySecret = initEarlySecret choice (Just psk)- usingHState ctx $ setTLS13EarlySecret earlySecret- let ech = encodeHandshake ch- h = cHash choice- siz = hashDigestSize h- binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech)- let exts' = init exts ++ [adjust (last exts)]- adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders- where- withBinders = replacePSKBinder withoutBinders binder- return exts'-- generateClientHelloParams =- case mparams of- -- Client random and session in the second client hello for- -- retry must be the same as the first one.- Just (crand, clientSession, _) -> return (crand, clientSession)- Nothing -> do- crand <- clientRandom ctx- let paramSession = case clientWantSessionResume cparams of- Nothing -> Session Nothing- Just (sid, sdata)- | sessionVersion sdata >= TLS13 -> Session Nothing- | ems == RequireEMS && noSessionEMS -> Session Nothing- | otherwise -> Session (Just sid)- where noSessionEMS = SessionEMS `notElem` sessionFlags sdata- -- In compatibility mode a client not offering a pre-TLS 1.3- -- session MUST generate a new 32-byte value- if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx)- then do- randomSession <- newSession ctx- return (crand, randomSession)- else return (crand, paramSession)-- sendClientHello clientSession crand = do- let ver = if tls13 then TLS12 else highestVer- 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 clientSession cipherIds compIds exts Nothing- pskInfo <- getPskInfo- let rtt0info = pskInfo >>= get0RTTinfo- rtt0 = isJust rtt0info- extensions0 <- catMaybes <$> getExtensions pskInfo rtt0- let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0- extensions <- adjustExtentions pskInfo extensions1 $ mkClientHello extensions1- sendPacket ctx $ Handshake [mkClientHello extensions]- mEarlySecInfo <- case rtt0info of- Nothing -> return Nothing- Just info -> Just <$> send0RTT info- unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo- return (rtt0, map (\(ExtensionRaw i _) -> i) extensions)-- get0RTTinfo (_, sdata, choice, _) = do- earlyData <- clientEarlyData cparams- guard (B.length earlyData <= sessionMaxEarlyDataSize sdata)- return (choice, earlyData)-- send0RTT (choice, earlyData) = 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- let clientEarlySecret = pairClient earlyKey- unless (ctxQUICMode ctx) $ do- runPacketFlight ctx $ sendChangeCipherSpec13 ctx- setTxState ctx usedHash usedCipher clientEarlySecret- let len = ctxFragmentSize ctx- mapChunks_ len (sendPacket13 ctx . AppData13) earlyData- -- We set RTT0Sent even in quicMode- usingHState ctx $ setTLS13RTT0Status RTT0Sent- return $ EarlySecretInfo usedCipher clientEarlySecret-- recvServerHello clientSession sentExts = runRecvState ctx recvState- where recvState = RecvStateNext $ \p ->- case p of- Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs -- this adds SH to hstHandshakeMessages- Alert a ->- case a of- [(AlertLevel_Warning, UnrecognizedName)] ->- if clientUseServerNameIndication cparams- then return recvState- else throwAlert a- _ -> throwAlert a- _ -> unexpected (show p) (Just "handshake")- throwAlert a = throwCore $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure)---- | Store the keypair and check that it is compatible with the current protocol--- version and a list of 'CertificateType' values.-storePrivInfoClient :: Context- -> [CertificateType]- -> Credential- -> IO ()-storePrivInfoClient ctx cTypes (cc, privkey) = do- pubkey <- storePrivInfo ctx cc privkey- unless (certificateCompatible pubkey cTypes) $- throwCore $ Error_Protocol- ( pubkeyType pubkey ++ " credential does not match allowed certificate types"- , True- , InternalError )- ver <- usingState_ ctx getVersion- unless (pubkey `versionCompatible` ver) $- throwCore $ Error_Protocol- ( pubkeyType pubkey ++ " credential is not supported at version " ++ show ver- , True- , InternalError )---- | When the server requests a client certificate, we try to--- obtain a suitable certificate chain and private key via the--- callback in the client parameters. It is OK for the callback--- to return an empty chain, in many cases the client certificate--- is optional. If the client wishes to abort the handshake for--- lack of a suitable certificate, it can throw an exception in--- the callback.------ The return value is 'Nothing' when no @CertificateRequest@ was--- received and no @Certificate@ message needs to be sent. An empty--- chain means that an empty @Certificate@ message needs to be sent--- to the server, naturally without a @CertificateVerify@. A non-empty--- 'CertificateChain' is the chain to send to the server along with--- a corresponding 'CertificateVerify'.------ With TLS < 1.2 the server's @CertificateRequest@ does not carry--- a signature algorithm list. It has a list of supported public--- key signing algorithms in the @certificate_types@ field. The--- hash is implicit. It is 'SHA1' for DSS and 'SHA1_MD5' for RSA.------ With TLS == 1.2 the server's @CertificateRequest@ always has a--- @supported_signature_algorithms@ list, as a fixed component of--- the structure. This list is (wrongly) overloaded to also limit--- X.509 signatures in the client's certificate chain. The BCP--- strategy is to find a compatible chain if possible, but else--- ignore the constraint, and let the server verify the chain as it--- sees fit. The @supported_signature_algorithms@ field is only--- obligatory with respect to signatures on TLS messages, in this--- case the @CertificateVerify@ message. The @certificate_types@--- field is still included.------ With TLS 1.3 the server's @CertificateRequest@ has a mandatory--- @signature_algorithms@ extension, the @signature_algorithms_cert@--- extension, which is optional, carries a list of algorithms the--- server promises to support in verifying the certificate chain.--- As with TLS 1.2, the client's makes a /best-effort/ to deliver--- a compatible certificate chain where all the CA signatures are--- known to be supported, but it should not abort the connection--- just because the chain might not work out, just send the best--- chain you have and let the server worry about the rest. The--- supported public key algorithms are now inferred from the--- @signature_algorithms@ extension and @certificate_types@ is--- gone.------ With TLS 1.3, we synthesize and store a @certificate_types@--- field at the time that the server's @CertificateRequest@--- message is received. This is then present across all the--- protocol versions, and can be used to determine whether--- a @CertificateRequest@ was received or not.------ If @signature_algorithms@ is 'Nothing', then we're doing--- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension--- is optional in TLS 1.3, and so the application callback--- will not be able to distinguish between TLS 1.[01] and--- TLS 1.3 with no certificate algorithm hints, but this--- just simplifies the chain selection process, all CA--- signatures are OK.----clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)-clientChain cparams ctx =- usingHState ctx getCertReqCBdata >>= \case- Nothing -> return Nothing- Just cbdata -> do- let callback = onCertificateRequest $ clientHooks cparams- chain <- liftIO $ callback cbdata `catchException`- throwMiscErrorOnException "certificate request callback failed"- case chain of- Nothing- -> return $ Just $ CertificateChain []- Just (CertificateChain [], _)- -> return $ Just $ CertificateChain []- Just cred@(cc, _)- -> do- let (cTypes, _, _) = cbdata- storePrivInfoClient ctx cTypes cred- return $ Just cc---- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with--- the local key and server's signature algorithms (both already saved). Must--- only be called for TLS versions 1.2 and up, with compatibility function--- 'signatureCompatible' or 'signatureCompatible13' based on version.------ The values in the server's @signature_algorithms@ extension are--- in descending order of preference. However here the algorithms--- are selected by client preference in @cHashSigs@.----getLocalHashSigAlg :: Context- -> (PubKey -> HashAndSignatureAlgorithm -> Bool)- -> [HashAndSignatureAlgorithm]- -> PubKey- -> IO HashAndSignatureAlgorithm-getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do- -- Must be present with TLS 1.2 and up.- (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata- let want = (&&) <$> isCompatible pubKey- <*> flip elem hashSigs- case find want cHashSigs of- Just best -> return best- Nothing -> throwCore $ Error_Protocol- ( keyerr pubKey- , True- , HandshakeFailure- )- where- keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server"---- | Return the supported 'CertificateType' values that are--- compatible with at least one supported signature algorithm.----supportedCtypes :: [HashAndSignatureAlgorithm]- -> [CertificateType]-supportedCtypes hashAlgs =- nub $ foldr ctfilter [] hashAlgs- where- ctfilter x acc = case hashSigToCertType x of- Just cType | cType <= lastSupportedCertificateType- -> cType : acc- _ -> acc----clientSupportedCtypes :: Context- -> [CertificateType]-clientSupportedCtypes ctx =- supportedCtypes $ supportedHashSignatures $ ctxSupported ctx----sigAlgsToCertTypes :: Context- -> [HashAndSignatureAlgorithm]- -> [CertificateType]-sigAlgsToCertTypes ctx hashSigs =- filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx---- | TLS 1.2 and below. Send the client handshake messages that--- follow the @ServerHello@, etc. except for @CCS@ and @Finished@.------ XXX: Is any buffering done here to combined these messages into--- a single TCP packet? Otherwise we're prone to Nagle delays, or--- in any case needlessly generate multiple small packets, where--- a single larger packet will do. The TLS 1.3 code path seems--- to separating record generation and transmission and sending--- multiple records in a single packet.------ -> [certificate]--- -> client key exchange--- -> [cert verify]-sendClientData :: ClientParams -> Context -> IO ()-sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify- where- sendCertificate = do- usingHState ctx $ setClientCertSent False- clientChain cparams ctx >>= \case- Nothing -> return ()- Just cc@(CertificateChain certs) -> do- unless (null certs) $- usingHState ctx $ setClientCertSent True- sendPacket ctx $ Handshake [Certificates cc]-- sendClientKeyXchg = do- cipher <- usingHState ctx getPendingCipher- (ckx, setMasterSec) <- case cipherKeyExchange cipher of- CipherKeyExchange_RSA -> do- clientVersion <- usingHState ctx $ gets hstClientVersion- (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46-- let premaster = encodePreMasterSecret clientVersion prerand- setMasterSec = setMasterSecretFromPre xver ClientRole premaster- encryptedPreMaster <- do- -- SSL3 implementation generally forget this length field since it's redundant,- -- however TLS10 make it clear that the length field need to be present.- e <- encryptRSA ctx premaster- let extra = if xver < TLS10- then B.empty- else encodeWord16 $ fromIntegral $ B.length e- return $ extra `B.append` e- return (CKX_RSA encryptedPreMaster, setMasterSec)- CipherKeyExchange_DHE_RSA -> getCKX_DHE- CipherKeyExchange_DHE_DSS -> getCKX_DHE- CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE- CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE- _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure)- sendPacket ctx $ Handshake [ClientKeyXchg ckx]- masterSecret <- usingHState ctx setMasterSec- logKey ctx (MasterSecret masterSecret)- where getCKX_DHE = do- xver <- usingState_ ctx getVersion- serverParams <- usingHState ctx getServerDHParams-- let params = serverDHParamsToParams serverParams- ffGroup = findFiniteFieldGroup params- srvpub = serverDHParamsToPublic serverParams-- unless (maybe False (isSupportedGroup ctx) ffGroup) $ do- groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException`- throwMiscErrorOnException "custom group callback failed"- case groupUsage of- GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity)- GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)- GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, IllegalParameter)- GroupUsageValid -> return ()-- -- When grp is known but not in the supported list we use it- -- anyway. This provides additional validation and a more- -- efficient implementation.- (clientDHPub, premaster) <-- case ffGroup of- Nothing -> do- (clientDHPriv, clientDHPub) <- generateDHE ctx params- let premaster = dhGetShared params clientDHPriv srvpub- return (clientDHPub, premaster)- Just grp -> do- usingHState ctx $ setNegotiatedGroup grp- dhePair <- generateFFDHEShared ctx grp srvpub- case dhePair of- Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter)- Just pair -> return pair-- let setMasterSec = setMasterSecretFromPre xver ClientRole premaster- return (CKX_DH clientDHPub, setMasterSec)-- getCKX_ECDHE = do- ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams- checkSupportedGroup ctx grp- usingHState ctx $ setNegotiatedGroup grp- ecdhePair <- generateECDHEShared ctx srvpub- case ecdhePair of- Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter)- Just (clipub, premaster) -> do- xver <- usingState_ ctx getVersion- let setMasterSec = setMasterSecretFromPre xver ClientRole premaster- return (CKX_ECDH $ encodeGroupPublic clipub, setMasterSec)-- -- In order to send a proper certificate verify message,- -- we have to do the following:- --- -- 1. Determine which signing algorithm(s) the server supports- -- (we currently only support RSA).- -- 2. Get the current handshake hash from the handshake state.- -- 3. Sign the handshake hash- -- 4. Send it to the server.- --- sendCertificateVerify = do- ver <- usingState_ ctx getVersion-- -- Only send a certificate verify message when we- -- have sent a non-empty list of certificates.- --- certSent <- usingHState ctx getClientCertSent- when certSent $ do- pubKey <- getLocalPublicKey ctx- mhashSig <- case ver of- TLS12 ->- let cHashSigs = supportedHashSignatures $ ctxSupported ctx- in Just <$> getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey- _ -> return Nothing-- -- Fetch all handshake messages up to now.- msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages- sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs- sendPacket ctx $ Handshake [CertVerify sigDig]--processServerExtension :: ExtensionRaw -> TLSSt ()-processServerExtension (ExtensionRaw extID content)- | extID == extensionID_SecureRenegotiation = do- cv <- getVerifiedData ClientRole- sv <- getVerifiedData ServerRole- let bs = extensionEncode (SecureRenegotiation cv $ Just sv)- unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)- | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of- Just (SupportedVersionsServerHello ver) -> setVersion ver- _ -> return ()- | extID == extensionID_KeyShare = do- hrr <- getTLS13HRR- let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello- setTLS13KeyShare $ extensionDecode msgt content- | extID == extensionID_PreSharedKey =- setTLS13PreSharedKey $ extensionDecode MsgTServerHello content-processServerExtension _ = return ()--throwMiscErrorOnException :: String -> SomeException -> IO a-throwMiscErrorOnException msg e =- throwCore $ Error_Misc $ msg ++ ": " ++ show e---- | onServerHello process 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--- 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--- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher----onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO)-onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do- when (rver == SSL2) $ throwCore $ Error_Protocol ("SSL2 is not supported", True, ProtocolVersion)- when (rver == SSL3) $ throwCore $ Error_Protocol ("SSL3 is not supported", True, ProtocolVersion)- -- find the compression and cipher methods that the server want to use.- cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, IllegalParameter)- Just alg -> return alg- compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter)- Just alg -> return alg-- -- 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 == extensionID_Cookie = False -- for HRR- | otherwise = i `notElem` sentExts- when (any checkExt exts) $- throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension)-- let resumingSession =- case clientWantSessionResume cparams of- Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing- Nothing -> Nothing- isHRR = isHelloRetryRequest serverRan- usingState_ ctx $ do- setTLS13HRR isHRR- setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello)- setSession serverSession (isJust resumingSession)- setVersion rver -- must be before processing supportedVersions ext- mapM_ processServerExtension exts-- setALPN ctx MsgTServerHello exts-- ver <- usingState_ ctx getVersion-- -- 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 (supportedVersions $ clientSupported cparams) serverRan) $- throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter)-- case find (== ver) (supportedVersions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion)- Just _ -> return ()- if ver > TLS12 then do- when (serverSession /= clientSession) $- throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter)- established <- ctxEstablished ctx- eof <- ctxEOF ctx- when (established == Established && not eof) $- throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion)- ensureNullCompression compression- failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg- return RecvStateDone- else do- ems <- processExtendedMasterSec ctx ver MsgTServerHello exts- usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg- case resumingSession of- Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx)- Just sessionData -> do- let emsSession = SessionEMS `elem` sessionFlags sessionData- when (ems /= emsSession) $- let err = "server resumes a session which is not EMS consistent"- in throwCore $ Error_Protocol (err, True, HandshakeFailure)- let masterSecret = sessionSecret sessionData- usingHState ctx $ setMasterSecret rver ClientRole masterSecret- logKey ctx (MasterSecret masterSecret)- return $ RecvStateNext expectChangeCipher-onServerHello _ _ _ _ p = unexpected (show p) (Just "server hello")--processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)-processCertificate cparams ctx (Certificates certs) = do- when (isNullCertificateChain certs) $- throwCore $ Error_Protocol ("server certificate missing", True, DecodeError)- -- run certificate recv hook- ctxWithHooks ctx (`hookRecvCertificates` certs)- -- then run certificate validation- usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException- case usage of- CertificateUsageAccept -> checkLeafCertificateKeyUsage- CertificateUsageReject reason -> certificateRejected reason- return $ RecvStateHandshake (processServerKeyExchange ctx)- where shared = clientShared cparams- checkCert = onServerCertificate (clientHooks cparams) (sharedCAStore shared)- (sharedValidationCache shared)- (clientServerIdentification cparams)- certs- -- also verify that the certificate optional key usage is compatible- -- with the intended key-exchange. This check is not delegated to- -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated- -- cipher, which is not available from onServerCertificate parameters.- -- Additionally, with only one shared ValidationCache, x509-validation- -- would cache validation result based on a key usage and reuse it with- -- another key usage.- checkLeafCertificateKeyUsage = do- cipher <- usingHState ctx getPendingCipher- case requiredCertKeyUsage cipher of- [] -> return ()- flags -> verifyLeafKeyUsage flags certs--processCertificate _ ctx p = processServerKeyExchange ctx p--expectChangeCipher :: Packet -> IO (RecvState IO)-expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish-expectChangeCipher p = unexpected (show p) (Just "change cipher")--expectFinish :: Handshake -> IO (RecvState IO)-expectFinish (Finished _) = return RecvStateDone-expectFinish p = unexpected (show p) (Just "Handshake Finished")--processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)-processServerKeyExchange ctx (ServerKeyXchg origSkx) = do- cipher <- usingHState ctx getPendingCipher- processWithCipher cipher origSkx- return $ RecvStateHandshake (processCertificateRequest ctx)- where processWithCipher cipher skx =- case (cipherKeyExchange cipher, skx) of- (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) ->- doDHESignature dhparams signature KX_RSA- (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) ->- doDHESignature dhparams signature KX_DSS- (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) ->- doECDHESignature ecdhparams signature KX_RSA- (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) ->- doECDHESignature ecdhparams signature KX_ECDSA- (cke, SKX_Unparsed bytes) -> do- ver <- usingState_ ctx getVersion- case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of- Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure)- Right realSkx -> processWithCipher cipher realSkx- -- we need to resolve the result. and recall processWithCipher ..- (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure)- doDHESignature dhparams signature kxsAlg = do- -- FF group selected by the server is verified when generating CKX- publicKey <- getSignaturePublicKey kxsAlg- verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature- unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams)- usingHState ctx $ setServerDHParams dhparams-- doECDHESignature ecdhparams signature kxsAlg = do- -- EC group selected by the server is verified when generating CKX- publicKey <- getSignaturePublicKey kxsAlg- verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature- unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams")- usingHState ctx $ setServerECDHParams ecdhparams-- getSignaturePublicKey kxsAlg = do- publicKey <- usingHState ctx getRemotePublicKey- unless (isKeyExchangeSignatureKey kxsAlg publicKey) $- throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure)- ver <- usingState_ ctx getVersion- unless (publicKey `versionCompatible` ver) $- throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey, True, IllegalParameter)- let groups = supportedGroups (ctxSupported ctx)- unless (satisfiesEcPredicate (`elem` groups) publicKey) $- throwCore $ Error_Protocol ("server public key has unsupported elliptic curve", True, IllegalParameter)- return publicKey--processServerKeyExchange ctx p = processCertificateRequest ctx p--processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)-processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do- ver <- usingState_ ctx getVersion- when (ver == TLS12 && isNothing sigAlgs) $- throwCore $ Error_Protocol- ( "missing TLS 1.2 certificate request signature algorithms"- , True- , InternalError- )- let cTypes = filter (<= lastSupportedCertificateType) cTypesSent- usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames)- return $ RecvStateHandshake (processServerHelloDone ctx)-processCertificateRequest ctx p = do- usingHState ctx $ setCertReqCBdata Nothing- processServerHelloDone ctx p--processServerHelloDone :: Context -> Handshake -> IO (RecvState m)-processServerHelloDone _ ServerHelloDone = return RecvStateDone-processServerHelloDone _ p = unexpected (show p) (Just "server hello data")---- Unless result is empty, server certificate must be allowed for at least one--- of the returned values. Constraints for RSA-based key exchange are relaxed--- to avoid rejecting certificates having incomplete extension.-requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]-requiredCertKeyUsage cipher =- case cipherKeyExchange cipher of- CipherKeyExchange_RSA -> rsaCompatibility- CipherKeyExchange_DH_Anon -> [] -- unrestricted- CipherKeyExchange_DHE_RSA -> rsaCompatibility- CipherKeyExchange_ECDHE_RSA -> rsaCompatibility- CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ]- CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ]- CipherKeyExchange_DH_RSA -> rsaCompatibility- CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ]- CipherKeyExchange_ECDH_RSA -> rsaCompatibility- CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ]- CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ]- where rsaCompatibility = [ KeyUsage_digitalSignature- , KeyUsage_keyEncipherment- , KeyUsage_keyAgreement- ]--handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()-handshakeClient13 cparams ctx groupSent = do- choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher- handshakeClient13' cparams ctx groupSent choice--handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()-handshakeClient13' cparams ctx groupSent choice = do- (_, hkey, resuming) <- switchToHandshakeSecret- let handshakeSecret = triBase hkey- clientHandshakeSecret = triClient hkey- serverHandshakeSecret = triServer hkey- handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret)- contextSync ctx $ RecvServerHello handSecInfo- (rtt0accepted,eexts) <- runRecvHandshake13 $ do- accext <- recvHandshake13 ctx expectEncryptedExtensions- unless resuming $ recvHandshake13 ctx expectCertRequest- recvHandshake13hash ctx $ expectFinished serverHandshakeSecret- return accext- hChSf <- transcriptHash ctx- unless (ctxQUICMode ctx) $- runPacketFlight ctx $ sendChangeCipherSpec13 ctx- when (rtt0accepted && not (ctxQUICMode ctx)) $- sendPacket13 ctx (Handshake13 [EndOfEarlyData13])- setTxState ctx usedHash usedCipher clientHandshakeSecret- sendClientFlight13 cparams ctx usedHash clientHandshakeSecret- appKey <- switchToApplicationSecret handshakeSecret hChSf- let applicationSecret = triBase appKey- setResumptionSecret applicationSecret- let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey)- contextSync ctx $ SendClientFinished eexts appSecInfo- handshakeTerminate13 ctx- where- usedCipher = cCipher choice- usedHash = cHash choice-- hashSize = hashDigestSize usedHash-- switchToHandshakeSecret = do- ensureRecvComplete ctx- ecdhe <- calcSharedKey- (earlySecret, resuming) <- makeEarlySecret- handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe- let serverHandshakeSecret = triServer handKey- setRxState ctx usedHash usedCipher serverHandshakeSecret- return (usedCipher, handKey, resuming)-- switchToApplicationSecret handshakeSecret hChSf = do- ensureRecvComplete ctx- appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf- let serverApplicationSecret0 = triServer appKey- let clientApplicationSecret0 = triClient appKey- setTxState ctx usedHash usedCipher clientApplicationSecret0- setRxState ctx usedHash usedCipher serverApplicationSecret0- return appKey-- calcSharedKey = do- serverKeyShare <- do- mks <- usingState_ ctx getTLS13KeyShare- case mks of- Just (KeyShareServerHello ks) -> return ks- Just _ -> throwCore $ Error_Protocol ("invalid key_share value", True, IllegalParameter)- Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure)- let grp = keyShareEntryGroup serverKeyShare- unless (checkKeyShareKeyLength serverKeyShare) $- throwCore $ Error_Protocol ("broken key_share", True, IllegalParameter)- unless (groupSent == Just grp) $- throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter)- usingHState ctx $ setNegotiatedGroup grp- usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare-- makeEarlySecret = do- mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret- case mEarlySecretPSK of- Nothing -> return (initEarlySecret choice Nothing, False)- Just earlySecretPSK@(BaseSecret sec) -> do- mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey- case mSelectedIdentity of- Nothing ->- return (initEarlySecret choice Nothing, False)- Just (PreSharedKeyServerHello 0) -> do- unless (B.length sec == hashSize) $- throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter)- usingHState ctx $ setTLS13HandshakeMode PreSharedKey- return (earlySecretPSK, True)- Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter)-- expectEncryptedExtensions (EncryptedExtensions13 eexts) = do- liftIO $ setALPN ctx MsgTEncryptedExtensions eexts- st <- usingHState ctx getTLS13RTT0Status- if st == RTT0Sent then- case extensionLookup extensionID_EarlyData eexts of- Just _ -> do- usingHState ctx $ setTLS13HandshakeMode RTT0- usingHState ctx $ setTLS13RTT0Status RTT0Accepted- return (True,eexts)- Nothing -> do- usingHState ctx $ setTLS13HandshakeMode RTT0- usingHState ctx $ setTLS13RTT0Status RTT0Rejected- return (False,eexts)- else- return (False,eexts)- expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions")-- expectCertRequest (CertRequest13 token exts) = do- processCertRequest13 ctx token exts- recvHandshake13 ctx expectCertAndVerify-- expectCertRequest other = do- usingHState ctx $ do- setCertReqToken Nothing- setCertReqCBdata Nothing- -- setCertReqSigAlgsCert Nothing- expectCertAndVerify other-- expectCertAndVerify (Certificate13 _ cc _) = do- _ <- liftIO $ processCertificate cparams ctx (Certificates cc)- let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc- ver <- liftIO $ usingState_ ctx getVersion- checkDigitalSignatureKey ver pubkey- usingHState ctx $ setPublicKey pubkey- recvHandshake13hash ctx $ expectCertVerify pubkey- expectCertAndVerify p = unexpected (show p) (Just "server certificate")-- expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do- ok <- checkCertVerify ctx pubkey sigAlg sig hChSc- unless ok $ decryptError "cannot verify CertificateVerify"- expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify")-- expectFinished (ServerTrafficSecret baseKey) hashValue (Finished13 verifyData) =- checkFinished ctx usedHash baseKey hashValue verifyData- expectFinished _ _ p = unexpected (show p) (Just "server finished")-- setResumptionSecret applicationSecret = do- resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret- usingHState ctx $ setTLS13ResumptionSecret resumptionSecret--processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()-processCertRequest13 ctx token exts = do- let hsextID = extensionID_SignatureAlgorithms- -- caextID = extensionID_SignatureAlgorithmsCert- dNames <- canames- -- The @signature_algorithms@ extension is mandatory.- hsAlgs <- extalgs hsextID unsighash- cTypes <- case hsAlgs of- Just as ->- let validAs = filter isHashSignatureValid13 as- in return $ sigAlgsToCertTypes ctx validAs- Nothing -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )- -- Unused:- -- caAlgs <- extalgs caextID uncertsig- usingHState ctx $ do- setCertReqToken $ Just token- setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)- -- setCertReqSigAlgsCert caAlgs- where- canames = case extensionLookup- extensionID_CertificateAuthorities exts of- Nothing -> return []- Just ext -> case extensionDecode MsgTCertificateRequest ext of- Just (CertificateAuthorities names) -> return names- _ -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )- extalgs extID decons = case extensionLookup extID exts of- Nothing -> return Nothing- Just ext -> case extensionDecode MsgTCertificateRequest ext of- Just e- -> return $ decons e- _ -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )- unsighash :: SignatureAlgorithms- -> Maybe [HashAndSignatureAlgorithm]- unsighash (SignatureAlgorithms a) = Just a- {- Unused for now- uncertsig :: SignatureAlgorithmsCert- -> Maybe [HashAndSignatureAlgorithm]- uncertsig (SignatureAlgorithmsCert a) = Just a- -}--sendClientFlight13 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()-sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do- chain <- clientChain cparams ctx- runPacketFlight ctx $ do- case chain of- Nothing -> return ()- Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc- rawFinished <- makeFinished ctx usedHash baseKey- loadPacket13 ctx $ Handshake13 [rawFinished]- where- sendClientData13 chain (Just token) = do- let (CertificateChain certs) = chain- certExts = replicate (length certs) []- cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx- loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]- case certs of- [] -> return ()- _ -> do- hChSc <- transcriptHash ctx- pubKey <- getLocalPublicKey ctx- sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey- vfy <- makeCertVerify ctx pubKey sigAlg hChSc- loadPacket13 ctx $ Handshake13 [vfy]- --- sendClientData13 _ _ =- throwCore $ Error_Protocol- ( "missing TLS 1.3 certificate request context token"- , True- , InternalError- )--setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()-setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of- Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do- mprotos <- getClientALPNSuggest- case mprotos of- Just protos -> when (proto `elem` protos) $ do- setExtensionALPN True- setNegotiatedProtocol proto- _ -> return ()- _ -> return ()--postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- processHandshake13 ctx h- processCertRequest13 ctx certReqCtx exts- (usedHash, _, level, applicationSecretN) <- getTxState ctx- unless (level == CryptApplicationSecret) $- throwCore $ Error_Protocol ("unexpected post-handshake authentication request", True, UnexpectedMessage)- sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN)--postHandshakeAuthClientWith _ _ _ =- throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage)--contextSync :: Context -> ClientState -> IO ()-contextSync ctx ctl = case ctxHandshakeSync ctx of- HandshakeSync sync _ -> sync ctx ctl+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Client (+ handshakeClient,+ handshakeClientWith,+ postHandshakeAuthClientWith,+) where++import Network.TLS.Context.Internal+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+import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13+import Network.TLS.IO+import Network.TLS.Imports+import Network.TLS.Measurement+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct++----------------------------------------------------------------++handshakeClientWith+ :: ClientParams -> Context -> HandshakeR -> IO ()+handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx+handshakeClientWith _ _ _ =+ throwCore $+ Error_Protocol+ "unexpected handshake message received in handshakeClientWith"+ HandshakeFailure++-- client part of handshake. send a bunch of handshake of client+-- values intertwined with response from the server.+handshakeClient :: ClientParams -> Context -> IO ()+handshakeClient cparams ctx = do+ 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 -> do+ let supported = grp : filter (/= grp) groupsSupported+ return $+ Groups+ { grpsSupported = supported+ , grpsSelected = [grp]+ }+ | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect"+ 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+-- ClientHello when the server has responded to its ClientHello with a+-- HelloRetryRequest. In that case, the client MUST send the same+-- ClientHello without modification, except as follows:"+--+-- So, the ClientRandom in the first client hello is necessary.+handshake+ :: ClientParams+ -> Context+ -> Groups+ -> Maybe (ClientRandom, Session, Version)+ -> IO ()+handshake cparams ctx grps@Groups{..} mparams = do+ --------------------------------+ -- Sending ClientHello+ pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx+ when rtt0 $ modifyTLS13State ctx $ \st -> st{tls13st0RTT = True}+ let async = rtt0 && not (ctxQUICMode ctx)+ when async $ do+ chSentTime <- getCurrentTimeFromBase+ asyncServerHello13 cparams ctx grpsSelected chSentTime+ updateMeasure ctx incrementNbHandshakes+ crand <-+ sendClientHello cparams ctx grps mparams pskinfo+ --------------------------------+ -- Receiving ServerHello+ unless async $ do+ (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 grpsSupported grpsSelected+ | otherwise -> do+ recvServerSecondFlight13 cparams ctx grpsSelected+ sendClientSecondFlight13 cparams ctx+ _+ | rtt0 ->+ throwCore $+ Error_Protocol+ "server denied TLS 1.3 when connecting with early data"+ HandshakeFailure+ | otherwise -> do+ recvServerFirstFlight12 cparams ctx hbs+ sendClientSecondFlight12 cparams ctx+ recvServerSecondFlight12 cparams ctx++----------------------------------------------------------------++helloRetry+ :: ClientParams+ -> Context+ -> Maybe a+ -> Version+ -> ClientRandom+ -> [Group]+ -> [Group]+ -> IO ()+helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do+ when (null groupsSupported) $+ throwCore $+ 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)+ -- 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+ -- 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+ Just _ -> error "handshake: invalid KeyShare value"+ Nothing ->+ throwCore $+ Error_Protocol+ "key exchange not implemented in HRR, expected key_share extension"+ HandshakeFailure
+ Network/TLS/Handshake/Client/ClientHello.hs view
@@ -0,0 +1,610 @@+{-# 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.Context.Internal+import Network.TLS.Crypto+import Network.TLS.Extension+import Network.TLS.Handshake.Client.Common+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Control+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)+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Types++----------------------------------------------------------------++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+ -> Groups+ -> Maybe (ClientRandom, Session, Version)+ -> PreSharedKeyInfo+ -> IO ClientRandom+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+ tls13 = highestVer >= TLS13+ ems = supportedExtendedMainSecret $ ctxSupported ctx++ -- Client random and session in the second client hello for+ -- retry must be the same as the first one.+ generateClientHelloParams (Just (crand, clientSession, _)) = do+ modifyTLS13State ctx $ \st -> st{tls13stSession = clientSession}+ return crand+ generateClientHelloParams Nothing = do+ crand <- clientRandom ctx+ 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+ | otherwise -> Session (Just sidOrTkt)+ where+ noSessionEMS = SessionEMS `notElem` sessionFlags sdata+ -- In compatibility mode a client not offering a pre-TLS 1.3+ -- session MUST generate a new 32-byte value+ if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx)+ then do+ randomSession <- newSession ctx+ modifyTLS13State ctx $ \st -> st{tls13stSession = randomSession}+ return crand+ else do+ modifyTLS13State ctx $ \st -> st{tls13stSession = paramSession}+ return crand++----------------------------------------------------------------++sendClientHello'+ :: ClientParams+ -> Context+ -> Groups+ -> ClientRandom+ -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32)+ , Maybe CipherChoice+ , Bool+ )+ -> IO ()+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 . 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 <- 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+ unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo+ let sentExtensions = map (\(ExtensionRaw i _) -> i) extensions+ modifyTLS13State ctx $ \st -> st{tls13stSentExtensions = sentExtensions}+ where+ ciphers = supportedCiphers $ ctxSupported ctx+ highestVer = maximum $ supportedVersions $ ctxSupported ctx+ tls13 = highestVer >= TLS13+ ems = supportedExtendedMainSecret $ ctxSupported ctx++ -- List of extensions to send in ClientHello, ordered such that we never+ -- terminate with a zero-length extension. Some buggy implementations+ -- are allergic to an extension with empty data at final position.+ --+ -- Without TLS 1.3, the list ends with extension "signature_algorithms"+ -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions+ -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key"+ -- (not always present) have length > 0.+ getExtensions =+ sequence+ [ {- 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)+ ]++ --------------------++ sniExt =+ if clientUseServerNameIndication cparams+ then do+ let sni = fst $ clientServerIdentification cparams+ usingState_ ctx $ setClientSNI sni+ return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni]+ else return Nothing++ -- 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]++ signatureAlgExt =+ return $+ Just $+ toExtensionRaw $+ SignatureAlgorithms $+ supportedHashSignatures $+ clientSupported cparams++ alpnExt = do+ mprotos <- onSuggestALPN $ clientHooks cparams+ case mprotos of+ Nothing -> return Nothing+ Just protos -> do+ usingState_ ctx $ setClientALPNSuggest protos+ return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos++ emsExt =+ return $+ if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)+ then Nothing+ else Just $ toExtensionRaw ExtendedMainSecret++ compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib])++ 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++ 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++ 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++ 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 (identities, sdata, choice, _) -> do+ let psk = sessionSecret sdata+ earlySecret = initEarlySecret choice (Just psk)+ usingHState ctx $ setTLS13EarlySecret earlySecret+ let ech = encodeHandshake $ ClientHello ch+ h = cHash choice+ siz = (hashDigestSize h + 1) * length identities + 2+ binder = makePSKBinder earlySecret h siz ech+ -- PSK is shared by the previous TLS session.+ -- So, PSK is unique for identities.+ let binders = replicate (length identities) binder+ let exts' = init exts ++ [adjust (last exts)]+ adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders+ where+ withBinders = replacePSKBinder withoutBinders binders+ return exts'++ getEarlySecretInfo choice = do+ let usedCipher = cCipher choice+ usedHash = cHash choice+ Just earlySecret <- usingHState ctx getTLS13EarlySecret+ earlyKey <- calculateEarlySecret ctx choice (Right earlySecret)+ let clientEarlySecret = pairClient earlyKey+ unless (ctxQUICMode ctx) $ do+ runPacketFlight ctx $ sendChangeCipherSpec13 ctx+ setTxRecordState ctx usedHash usedCipher clientEarlySecret+ setEstablished ctx EarlyDataSending+ -- We set RTT0Sent even in quicMode+ usingHState ctx $ setTLS13RTT0Status RTT0Sent+ return $ EarlySecretInfo usedCipher clientEarlySecret++----------------------------------------------------------------++type PreSharedKeyInfo =+ ( Maybe ([SessionIDorTicket], SessionData, CipherChoice, Second)+ , Maybe CipherChoice+ , Bool+ )++getPreSharedKeyInfo+ :: ClientParams+ -> Context+ -> IO PreSharedKeyInfo+getPreSharedKeyInfo cparams ctx = do+ pskInfo <- getPskInfo+ let rtt0info = pskInfo >>= get0RTTinfo+ rtt0 = isJust rtt0info+ return (pskInfo, rtt0info, rtt0)+ where+ ciphers = supportedCiphers $ ctxSupported ctx+ highestVer = maximum $ supportedVersions $ ctxSupported ctx+ tls13 = highestVer >= TLS13++ sessions = case clientSessions cparams of+ [] -> Nothing+ (sid, sdata) : xs -> do+ guard tls13+ guard (sessionVersion sdata >= TLS13)+ let cid = sessionCipher sdata+ sids = map fst xs+ sCipher <- findCipher cid ciphers+ Just (sid : sids, sdata, sCipher)++ getPskInfo = case sessions of+ Nothing -> return Nothing+ Just (identity, sdata, sCipher) -> do+ let tinfo = fromJust $ sessionTicketInfo sdata+ age <- getAge tinfo+ return $+ if isAgeValid age tinfo+ then+ Just+ ( identity+ , sdata+ , makeCipherChoice TLS13 sCipher+ , ageToObfuscatedAge age tinfo+ )+ else Nothing++ get0RTTinfo (_, sdata, choice, _)+ | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 = Just choice+ | otherwise = Nothing++----------------------------------------------------------------++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+ sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host]+ (os, is) = step3 exts id+ step2 _ = error "step2"+ 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
@@ -0,0 +1,363 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Client.Common (+ throwMiscErrorOnException,+ doServerKeyExchange,+ doCertificate,+ getLocalHashSigAlg,+ clientChain,+ sigAlgsToCertTypes,+ setALPN,+ contextSync,+ clientSessions,+) where++import Control.Exception (SomeException)+import Control.Monad.State.Strict+import Data.X509 (ExtKeyUsageFlag (..))++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Credentials+import Network.TLS.Crypto+import Network.TLS.Extension+import Network.TLS.Handshake.Certificate+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Control+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Packet hiding (getExtensions)+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Util (catchException)+import Network.TLS.X509++----------------------------------------------------------------++throwMiscErrorOnException :: String -> SomeException -> IO a+throwMiscErrorOnException msg e =+ throwCore $ Error_Misc $ msg ++ ": " ++ show e++----------------------------------------------------------------++doServerKeyExchange :: Context -> ServerKeyXchgAlgorithmData -> IO ()+doServerKeyExchange ctx origSkx = do+ cipher <- usingHState ctx getPendingCipher+ processWithCipher cipher origSkx+ where+ processWithCipher cipher skx =+ case (cipherKeyExchange cipher, skx) of+ (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) ->+ doDHESignature dhparams signature KX_RSA+ (CipherKeyExchange_DHE_DSA, SKX_DHE_DSA dhparams signature) ->+ doDHESignature dhparams signature KX_DSA+ (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) ->+ doECDHESignature ecdhparams signature KX_RSA+ (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) ->+ doECDHESignature ecdhparams signature KX_ECDSA+ (cke, SKX_Unparsed bytes) -> do+ ver <- usingState_ ctx getVersion+ case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of+ Left _ ->+ throwCore $+ Error_Protocol+ ("unknown server key exchange received, expecting: " ++ show cke)+ HandshakeFailure+ Right realSkx -> processWithCipher cipher realSkx+ -- we need to resolve the result. and recall processWithCipher ..+ (c, _) ->+ throwCore $+ Error_Protocol+ ("unknown server key exchange received, expecting: " ++ show c)+ HandshakeFailure+ doDHESignature dhparams signature kxsAlg = do+ -- FF group selected by the server is verified when generating CKX+ publicKey <- getSignaturePublicKey kxsAlg+ verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature+ unless verified $+ decryptError+ ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams)+ usingHState ctx $ setServerDHParams dhparams++ doECDHESignature ecdhparams signature kxsAlg = do+ -- EC group selected by the server is verified when generating CKX+ publicKey <- getSignaturePublicKey kxsAlg+ verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature+ unless verified $+ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams")+ usingHState ctx $ setServerECDHParams ecdhparams++ getSignaturePublicKey kxsAlg = do+ publicKey <- usingHState ctx getRemotePublicKey+ unless (isKeyExchangeSignatureKey kxsAlg publicKey) $+ throwCore $+ Error_Protocol+ ("server public key algorithm is incompatible with " ++ show kxsAlg)+ HandshakeFailure+ ver <- usingState_ ctx getVersion+ unless (publicKey `versionCompatible` ver) $+ throwCore $+ Error_Protocol+ (show ver ++ " has no support for " ++ pubkeyType publicKey)+ IllegalParameter+ let groups = supportedGroups (ctxSupported ctx)+ unless (satisfiesEcPredicate (`elem` groups) publicKey) $+ throwCore $+ Error_Protocol+ "server public key has unsupported elliptic curve"+ IllegalParameter+ return publicKey++----------------------------------------------------------------++doCertificate :: ClientParams -> Context -> CertificateChain -> IO ()+doCertificate cparams ctx certs = do+ when (isNullCertificateChain certs) $+ throwCore $+ Error_Protocol "server certificate missing" DecodeError+ -- run certificate recv hook+ ctxWithHooks ctx (`hookRecvCertificates` certs)+ -- then run certificate validation+ usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException+ case usage of+ CertificateUsageAccept -> checkLeafCertificateKeyUsage+ CertificateUsageReject reason -> certificateRejected reason+ where+ shared = clientShared cparams+ checkCert =+ onServerCertificate+ (clientHooks cparams)+ (sharedCAStore shared)+ (sharedValidationCache shared)+ (clientServerIdentification cparams)+ certs+ -- also verify that the certificate optional key usage is compatible+ -- with the intended key-exchange. This check is not delegated to+ -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated+ -- cipher, which is not available from onServerCertificate parameters.+ -- Additionally, with only one shared ValidationCache, x509-validation+ -- would cache validation result based on a key usage and reuse it with+ -- another key usage.+ checkLeafCertificateKeyUsage = do+ cipher <- usingHState ctx getPendingCipher+ case requiredCertKeyUsage cipher of+ [] -> return ()+ flags -> verifyLeafKeyUsage flags certs++-- Unless result is empty, server certificate must be allowed for at least one+-- of the returned values. Constraints for RSA-based key exchange are relaxed+-- to avoid rejecting certificates having incomplete extension.+requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]+requiredCertKeyUsage cipher =+ case cipherKeyExchange cipher of+ CipherKeyExchange_RSA -> rsaCompatibility+ CipherKeyExchange_DH_Anon -> [] -- unrestricted+ CipherKeyExchange_DHE_RSA -> rsaCompatibility+ CipherKeyExchange_ECDHE_RSA -> rsaCompatibility+ CipherKeyExchange_DHE_DSA -> [KeyUsage_digitalSignature]+ CipherKeyExchange_DH_DSA -> [KeyUsage_keyAgreement]+ CipherKeyExchange_DH_RSA -> rsaCompatibility+ CipherKeyExchange_ECDH_ECDSA -> [KeyUsage_keyAgreement]+ CipherKeyExchange_ECDH_RSA -> rsaCompatibility+ CipherKeyExchange_ECDHE_ECDSA -> [KeyUsage_digitalSignature]+ CipherKeyExchange_TLS13 -> [KeyUsage_digitalSignature]+ where+ rsaCompatibility =+ [ KeyUsage_digitalSignature+ , KeyUsage_keyEncipherment+ , KeyUsage_keyAgreement+ ]++----------------------------------------------------------------++-- | Return the supported 'CertificateType' values that are+-- compatible with at least one supported signature algorithm.+supportedCtypes+ :: [HashAndSignatureAlgorithm]+ -> [CertificateType]+supportedCtypes hashAlgs =+ nub $ foldr ctfilter [] hashAlgs+ where+ ctfilter x acc = case hashSigToCertType x of+ Just cType+ | cType <= lastSupportedCertificateType ->+ cType : acc+ _ -> acc++clientSupportedCtypes+ :: Context+ -> [CertificateType]+clientSupportedCtypes ctx =+ supportedCtypes $ supportedHashSignatures $ ctxSupported ctx++sigAlgsToCertTypes+ :: Context+ -> [HashAndSignatureAlgorithm]+ -> [CertificateType]+sigAlgsToCertTypes ctx hashSigs =+ filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx++----------------------------------------------------------------++-- | When the server requests a client certificate, we try to+-- obtain a suitable certificate chain and private key via the+-- callback in the client parameters. It is OK for the callback+-- to return an empty chain, in many cases the client certificate+-- is optional. If the client wishes to abort the handshake for+-- lack of a suitable certificate, it can throw an exception in+-- the callback.+--+-- The return value is 'Nothing' when no @CertificateRequest@ was+-- received and no @Certificate@ message needs to be sent. An empty+-- chain means that an empty @Certificate@ message needs to be sent+-- to the server, naturally without a @CertificateVerify@. A non-empty+-- 'CertificateChain' is the chain to send to the server along with+-- a corresponding 'CertificateVerify'.+--+-- With TLS < 1.2 the server's @CertificateRequest@ does not carry+-- a signature algorithm list. It has a list of supported public+-- key signing algorithms in the @certificate_types@ field. The+-- hash is implicit. It is 'SHA1' for DSA and 'SHA1_MD5' for RSA.+--+-- With TLS == 1.2 the server's @CertificateRequest@ always has a+-- @supported_signature_algorithms@ list, as a fixed component of+-- the structure. This list is (wrongly) overloaded to also limit+-- X.509 signatures in the client's certificate chain. The BCP+-- strategy is to find a compatible chain if possible, but else+-- ignore the constraint, and let the server verify the chain as it+-- sees fit. The @supported_signature_algorithms@ field is only+-- obligatory with respect to signatures on TLS messages, in this+-- case the @CertificateVerify@ message. The @certificate_types@+-- field is still included.+--+-- With TLS 1.3 the server's @CertificateRequest@ has a mandatory+-- @signature_algorithms@ extension, the @signature_algorithms_cert@+-- extension, which is optional, carries a list of algorithms the+-- server promises to support in verifying the certificate chain.+-- As with TLS 1.2, the client's makes a /best-effort/ to deliver+-- a compatible certificate chain where all the CA signatures are+-- known to be supported, but it should not abort the connection+-- just because the chain might not work out, just send the best+-- chain you have and let the server worry about the rest. The+-- supported public key algorithms are now inferred from the+-- @signature_algorithms@ extension and @certificate_types@ is+-- gone.+--+-- With TLS 1.3, we synthesize and store a @certificate_types@+-- field at the time that the server's @CertificateRequest@+-- message is received. This is then present across all the+-- protocol versions, and can be used to determine whether+-- a @CertificateRequest@ was received or not.+--+-- If @signature_algorithms@ is 'Nothing', then we're doing+-- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension+-- is optional in TLS 1.3, and so the application callback+-- will not be able to distinguish between TLS 1.[01] and+-- TLS 1.3 with no certificate algorithm hints, but this+-- just simplifies the chain selection process, all CA+-- signatures are OK.+clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)+clientChain cparams ctx =+ usingHState ctx getCertReqCBdata >>= \case+ Nothing -> return Nothing+ Just cbdata -> do+ let callback = onCertificateRequest $ clientHooks cparams+ chain <-+ liftIO $+ callback cbdata+ `catchException` throwMiscErrorOnException "certificate request callback failed"+ case chain of+ Nothing ->+ return $ Just $ CertificateChain []+ Just (CertificateChain [], _) ->+ return $ Just $ CertificateChain []+ Just cred@(cc, _) ->+ do+ let (cTypes, _, _) = cbdata+ storePrivInfoClient ctx cTypes cred+ return $ Just cc++-- | Store the keypair and check that it is compatible with the current protocol+-- version and a list of 'CertificateType' values.+storePrivInfoClient+ :: Context+ -> [CertificateType]+ -> Credential+ -> IO ()+storePrivInfoClient ctx cTypes (cc, privkey) = do+ pubkey <- storePrivInfo ctx cc privkey+ unless (certificateCompatible pubkey cTypes) $+ throwCore $+ Error_Protocol+ (pubkeyType pubkey ++ " credential does not match allowed certificate types")+ InternalError+ ver <- usingState_ ctx getVersion+ unless (pubkey `versionCompatible` ver) $+ throwCore $+ Error_Protocol+ (pubkeyType pubkey ++ " credential is not supported at version " ++ show ver)+ InternalError++----------------------------------------------------------------++-- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with+-- the local key and server's signature algorithms (both already saved). Must+-- only be called for TLS versions 1.2 and up, with compatibility function+-- 'signatureCompatible' or 'signatureCompatible13' based on version.+--+-- The values in the server's @signature_algorithms@ extension are+-- in descending order of preference. However here the algorithms+-- are selected by client preference in @cHashSigs@.+getLocalHashSigAlg+ :: Context+ -> (PubKey -> HashAndSignatureAlgorithm -> Bool)+ -> [HashAndSignatureAlgorithm]+ -> PubKey+ -> IO HashAndSignatureAlgorithm+getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do+ -- Must be present with TLS 1.2 and up.+ (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata+ let want =+ (&&)+ <$> isCompatible pubKey+ <*> flip elem hashSigs+ case find want cHashSigs of+ Just best -> return best+ Nothing -> throwCore $ Error_Protocol (keyerr pubKey) HandshakeFailure+ where+ keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server"++----------------------------------------------------------------++setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()+setALPN ctx msgt exts =+ lookupAndDecodeAndDo+ EID_ApplicationLayerProtocolNegotiation+ msgt+ exts+ (return ())+ setAlpn+ where+ setAlpn (ApplicationLayerProtocolNegotiation [proto]) = usingState_ ctx $ do+ mprotos <- getClientALPNSuggest+ case mprotos of+ Just protos -> when (proto `elem` protos) $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ _ -> return ()+ setAlpn _ = return ()++----------------------------------------------------------------++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
@@ -0,0 +1,306 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Client.ServerHello (+ 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+import Network.TLS.ErrT+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.Random+import Network.TLS.Handshake.State+import Network.TLS.Handshake.TranscriptHash+import Network.TLS.IO+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types++----------------------------------------------------------------++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+ 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+ case epkt of+ Left e -> throwCore e+ Right pkt -> case pkt of+ Alert a -> throwAlert a+ Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs)+ _ -> unexpected (show pkt) (Just "handshake")+ throwAlert a =+ throwCore $+ Error_Protocol+ ("expecting server hello, got alert : " ++ show a)+ HandshakeFailure++----------------------------------------------------------------++processServerHello13+ :: ClientParams -> Context -> Handshake13 -> IO ()+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+-- 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+processServerHello+ :: ClientParams -> Context -> Handshake -> IO ()+processServerHello cparams ctx (ServerHello sh@SH{..}) = do+ -- A server which receives a legacy_version value not equal to+ -- 0x0303 MUST abort the handshake with an "illegal_parameter"+ -- alert.+ when (shVersion /= TLS12) $+ throwCore $+ Error_Protocol (show shVersion ++ " is not supported") IllegalParameter+ -- find the compression and cipher methods that the server want to use.+ clientSession <- tls13stSession <$> getTLS13State ctx+ 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+ ((==) shComp . compressionID)+ (supportedCompressions $ ctxSupported ctx) of+ Nothing ->+ throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter+ Just alg -> return alg+ ensureNullCompression shComp++ -- 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` chExts+ when (any checkExt shExtensions) $+ throwCore $+ Error_Protocol "spurious extensions received" UnsupportedExtension++ let isHRR = isHelloRetryRequest shRandom+ usingState_ ctx $ do+ setTLS13HRR isHRR+ 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 shExtensions++ ver <- usingState_ ctx getVersion++ when (ver == TLS12) $+ setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg++ let supportedVers = supportedVersions $ clientSupported cparams++ when (ver == TLS13) $ do+ -- TLS 1.3 server MUST echo the session id+ when (clientSession /= shSession) $+ throwCore $+ Error_Protocol+ "session is not matched in compatibility mode"+ IllegalParameter+ when (ver `notElem` supportedVers) $+ throwCore $+ Error_Protocol+ ("server version " ++ show ver ++ " is not supported")+ ProtocolVersion++ -- Some servers set TLS 1.2 as the legacy server hello version,+ -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set+ -- 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 shRandom) $+ throwCore $+ Error_Protocol "version downgrade detected" IllegalParameter++ if ver == TLS13+ 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")++----------------------------------------------------------------++processServerExtension :: ExtensionRaw -> TLSSt ()+processServerExtension (ExtensionRaw extID content)+ | extID == EID_SecureRenegotiation = do+ VerifyData cvd <- getVerifyData ClientRole+ VerifyData svd <- getVerifyData ServerRole+ let bs = extensionEncode $ SecureRenegotiation cvd svd+ unless (bs == content) $+ throwError $+ Error_Protocol "server secure renegotiation data not matching" HandshakeFailure+ | extID == EID_SupportedVersions = case extensionDecode MsgTServerHello content of+ Just (SupportedVersionsServerHello ver) -> setVersion ver+ _ -> return ()+ | extID == EID_KeyShare = do+ hrr <- getTLS13HRR+ let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello+ setTLS13KeyShare $ extensionDecode msgt content+ | extID == EID_PreSharedKey =+ setTLS13PreSharedKey $ extensionDecode MsgTServerHello content+ | extID == EID_SessionTicket = setTLS12SessionTicket "" -- empty ticket+processServerExtension _ = return ()++----------------------------------------------------------------++updateContext13 :: Context -> Cipher -> Bool -> IO ()+updateContext13 ctx usedCipher isHRR = do+ established <- ctxEstablished ctx+ eof <- ctxEOF ctx+ when (established == Established && not eof) $+ throwCore $+ Error_Protocol+ "renegotiation to TLS 1.3 or later is not allowed"+ ProtocolVersion+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher isHRR++updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()+updateContext12 ctx shExtensions resumingSession = do+ ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExtensions+ case resumingSession of+ Nothing -> return ()+ Just sessionData -> do+ let emsSession = SessionEMS `elem` sessionFlags sessionData+ when (ems /= emsSession) $+ let err = "server resumes a session which is not EMS consistent"+ in throwCore $ Error_Protocol err HandshakeFailure+ 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
@@ -0,0 +1,288 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.Client.TLS12 (+ recvServerFirstFlight12,+ sendClientSecondFlight12,+ recvServerSecondFlight12,+) where++import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Crypto+import Network.TLS.Handshake.Client.Common+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.State+import Network.TLS.IO+import Network.TLS.Imports+import Network.TLS.Packet hiding (getExtensions, getSession)+import Network.TLS.Parameters+import Network.TLS.Session+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Types+import Network.TLS.Util (catchException)+import Network.TLS.Wire+import Network.TLS.X509 hiding (Certificate)++----------------------------------------------------------------++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 hbs++expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)+expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do+ usingState_ ctx $ setServerCertificateChain certs+ doCertificate cparams ctx certs+ processCertificate ctx ClientRole certs+ return $ RecvStateHandshake (expectServerKeyExchange ctx)+expectCertificate _ ctx p = expectServerKeyExchange ctx p++expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)+expectServerKeyExchange ctx (ServerKeyXchg origSkx) = do+ doServerKeyExchange ctx origSkx+ return $ RecvStateHandshake (expectCertificateRequest ctx)+expectServerKeyExchange ctx p = expectCertificateRequest ctx p++expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO)+expectCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do+ let cTypes = filter (<= lastSupportedCertificateType) cTypesSent+ usingHState ctx $ setCertReqCBdata $ Just (cTypes, Just sigAlgs, dNames)+ return $ RecvStateHandshake (expectServerHelloDone ctx)+expectCertificateRequest ctx p = do+ usingHState ctx $ setCertReqCBdata Nothing+ expectServerHelloDone ctx p++expectServerHelloDone :: Context -> Handshake -> IO (RecvState m)+expectServerHelloDone _ ServerHelloDone = return RecvStateDone+expectServerHelloDone _ p = unexpected (show p) (Just "server hello data")++----------------------------------------------------------------++sendClientSecondFlight12 :: ClientParams -> Context -> IO ()+sendClientSecondFlight12 cparams ctx = do+ sessionResuming <- usingState_ ctx getTLS12SessionResuming+ if sessionResuming+ then sendCCSandFinished ctx ClientRole+ else do+ sendClientCCC cparams ctx+ sendCCSandFinished ctx ClientRole++recvServerSecondFlight12 :: ClientParams -> Context -> IO ()+recvServerSecondFlight12 cparams ctx = do+ sessionResuming <- usingState_ ctx getTLS12SessionResuming+ unless sessionResuming $ recvNSTandCCSandFinished ctx+ mticket <- usingState_ ctx getTLS12SessionTicket+ 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+ st <- isJust <$> usingState_ ctx getTLS12SessionTicket+ if st+ then runRecvState ctx $ RecvStateHandshake expectNewSessionTicket+ else do runRecvState ctx $ RecvStatePacket expectChangeCipher+ where+ expectNewSessionTicket (NewSessionTicket _ ticket) = do+ usingState_ ctx $ setTLS12SessionTicket ticket+ return $ RecvStatePacket expectChangeCipher+ 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")++----------------------------------------------------------------++-- | TLS 1.2 and below. Send the client handshake messages that+-- follow the @ServerHello@, etc. except for @CCS@ and @Finished@.+--+-- XXX: Is any buffering done here to combined these messages into+-- a single TCP packet? Otherwise we're prone to Nagle delays, or+-- in any case needlessly generate multiple small packets, where+-- a single larger packet will do. The TLS 1.3 code path seems+-- to separating record generation and transmission and sending+-- multiple records in a single packet.+--+-- -> [certificate]+-- -> client key exchange+-- -> [cert verify]+sendClientCCC :: ClientParams -> Context -> IO ()+sendClientCCC cparams ctx = do+ sendCertificate cparams ctx+ sendClientKeyXchg cparams ctx+ sendCertificateVerify ctx++----------------------------------------------------------------++sendCertificate :: ClientParams -> Context -> IO ()+sendCertificate cparams ctx = do+ usingHState ctx $ setClientCertSent False+ clientChain cparams ctx >>= \case+ Nothing -> return ()+ Just cc@(CertificateChain certs) -> do+ unless (null certs) $+ usingHState ctx $+ setClientCertSent True+ sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] []++----------------------------------------------------------------++sendClientKeyXchg :: ClientParams -> Context -> IO ()+sendClientKeyXchg cparams ctx = do+ cipher <- usingHState ctx getPendingCipher+ (ckx, setMainSec) <- case cipherKeyExchange cipher of+ CipherKeyExchange_RSA -> getCKX_RSA ctx+ CipherKeyExchange_DHE_RSA -> getCKX_DHE cparams ctx+ CipherKeyExchange_DHE_DSA -> getCKX_DHE cparams ctx+ CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE ctx+ CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE ctx+ _ ->+ throwCore $+ Error_Protocol "client key exchange unsupported type" HandshakeFailure+ sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] []+ mainSecret <- usingHState ctx setMainSec+ logKey ctx (MainSecret mainSecret)++--------------------------------++getCKX_RSA+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret)+getCKX_RSA ctx = do+ clientVersion <- usingHState ctx $ gets hstClientVersion+ (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46++ let preMain = convert $ encodePreMainSecret clientVersion prerand+ setMainSec = setMainSecretFromPre xver ClientRole preMain+ encryptedPreMain <- do+ -- SSL3 implementation generally forget this length field since it's redundant,+ -- however TLS10 make it clear that the length field need to be present.+ e <- encryptRSA ctx preMain+ let extra = encodeWord16 $ fromIntegral $ B.length e+ return $ extra `B.append` e+ return (CKX_RSA encryptedPreMain, setMainSec)++--------------------------------++getCKX_DHE+ :: ClientParams+ -> Context+ -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret)+getCKX_DHE cparams ctx = do+ xver <- usingState_ ctx getVersion+ serverParams <- usingHState ctx getServerDHParams++ let params = serverDHParamsToParams serverParams+ ffGroup = findFiniteFieldGroup params+ srvpub = serverDHParamsToPublic serverParams++ unless (maybe False (isSupportedGroup ctx) ffGroup) $ do+ groupUsage <-+ onCustomFFDHEGroup (clientHooks cparams) params srvpub+ `catchException` throwMiscErrorOnException "custom group callback failed"+ case groupUsage of+ GroupUsageInsecure ->+ throwCore $+ Error_Protocol "FFDHE group is not secure enough" InsufficientSecurity+ GroupUsageUnsupported reason ->+ throwCore $+ Error_Protocol ("unsupported FFDHE group: " ++ reason) HandshakeFailure+ GroupUsageInvalidPublic -> throwCore $ Error_Protocol "invalid server public key" IllegalParameter+ GroupUsageValid -> return ()++ -- When grp is known but not in the supported list we use it+ -- anyway. This provides additional validation and a more+ -- efficient implementation.+ (clientDHPub, preMain) <-+ case ffGroup of+ Nothing -> do+ (clientDHPriv, clientDHPub) <- generateDHE ctx params+ let preMain = dhGetShared params clientDHPriv srvpub+ return (clientDHPub, preMain)+ Just grp -> do+ usingHState ctx $ setSupportedGroup grp+ dhePair <- generateFFDHEShared ctx grp srvpub+ case dhePair of+ Nothing ->+ throwCore $+ Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter+ Just pair -> return pair++ let setMainSec = setMainSecretFromPre xver ClientRole preMain+ return (CKX_DH clientDHPub, setMainSec)++--------------------------------++getCKX_ECDHE+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret)+getCKX_ECDHE ctx = do+ ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams+ checkSupportedGroup ctx grp+ usingHState ctx $ setSupportedGroup grp+ ecdhePair <- encapsulateGroup ctx srvpub+ case ecdhePair of+ Nothing ->+ throwCore $+ Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter+ Just (clipub, preMain) -> do+ xver <- usingState_ ctx getVersion+ let setMainSec = setMainSecretFromPre xver ClientRole preMain+ return (CKX_ECDH $ groupEncodePublicB clipub, setMainSec)++----------------------------------------------------------------++-- In order to send a proper certificate verify message,+-- we have to do the following:+--+-- 1. Determine which signing algorithm(s) the server supports+-- (we currently only support RSA).+-- 2. Get the current handshake hash from the handshake state.+-- 3. Sign the handshake hash+-- 4. Send it to the server.+--+sendCertificateVerify :: Context -> IO ()+sendCertificateVerify ctx = do+ ver <- usingState_ ctx getVersion++ -- Only send a certificate verify message when we+ -- have sent a non-empty list of certificates.+ --+ certSent <- usingHState ctx getClientCertSent+ when certSent $ do+ pubKey <- getLocalPublicKey ctx+ mhashSig <-+ let cHashSigs = supportedHashSignatures $ ctxSupported ctx+ in getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey+ -- 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] []
+ Network/TLS/Handshake/Client/TLS13.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.Client.TLS13 (+ recvServerSecondFlight13,+ sendClientSecondFlight13,+ asyncServerHello13,+ postHandshakeAuthClientWith,+) where++import Control.Exception (bracket)+import Control.Monad.State.Strict+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+import Network.TLS.Handshake.Common hiding (expectFinished)+import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Control+import Network.TLS.Handshake.Key+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.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types+import Network.TLS.X509++----------------------------------------------------------------+----------------------------------------------------------------++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 "Finished" $ expectFinished cparams ctx++----------------------------------------------------------------++prepareSecondFlight13+ :: Context -> [Group] -> IO Bool+prepareSecondFlight13 ctx groupSent = do+ choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher+ prepareSecondFlight13' ctx groupSent choice++prepareSecondFlight13'+ :: Context+ -> [Group]+ -> CipherChoice+ -> IO Bool+prepareSecondFlight13' ctx groupSent choice = do+ (_, hkey, resuming) <- switchToHandshakeSecret+ let clientHandshakeSecret = triClient hkey+ serverHandshakeSecret = triServer hkey+ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret)+ contextSync ctx $ RecvServerHello handSecInfo+ modifyTLS13State ctx $ \st ->+ st+ { tls13stChoice = choice+ , tls13stHsKey = Just hkey+ }+ return resuming+ where+ usedCipher = cCipher choice+ usedHash = cHash choice++ hashSize = hashDigestSize usedHash++ switchToHandshakeSecret = do+ ensureRecvComplete ctx+ ecdhe <- calcSharedKey+ (earlySecret, resuming) <- makeEarlySecret+ handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe+ let serverHandshakeSecret = triServer handKey+ setRxRecordState ctx usedHash usedCipher serverHandshakeSecret+ return (usedCipher, handKey, resuming)++ calcSharedKey = do+ serverKeyShare <- do+ mks <- usingState_ ctx getTLS13KeyShare+ case mks of+ Just (KeyShareServerHello ks) -> return ks+ Just _ ->+ throwCore $ Error_Protocol "invalid key_share value" IllegalParameter+ Nothing ->+ throwCore $+ Error_Protocol+ "key exchange not implemented, expected key_share extension"+ HandshakeFailure+ let grp = keyShareEntryGroup serverKeyShare+ unless (checkServerKeyShareKeyLength serverKeyShare) $+ throwCore $+ Error_Protocol "broken key_share" IllegalParameter+ unless (grp `elem` groupSent) $+ throwCore $+ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter+ usingHState ctx $ setSupportedGroup grp+ usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare++ makeEarlySecret = do+ mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret+ case mEarlySecretPSK of+ Nothing -> return (initEarlySecret choice Nothing, False)+ Just earlySecretPSK@(BaseSecret sec) -> do+ mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey+ case mSelectedIdentity of+ Nothing ->+ return (initEarlySecret choice Nothing, False)+ Just (PreSharedKeyServerHello 0) -> do+ unless (BA.length sec == hashSize) $+ throwCore $+ Error_Protocol+ "selected cipher is incompatible with selected PSK"+ IllegalParameter+ usingHState ctx $ setTLS13HandshakeMode PreSharedKey+ return (earlySecretPSK, True)+ Just _ ->+ throwCore $ Error_Protocol "selected identity out of range" IllegalParameter++----------------------------------------------------------------++expectEncryptedExtensions+ :: MonadIO m => Context -> Handshake13 -> m ()+expectEncryptedExtensions ctx (EncryptedExtensions13 eexts) = do+ liftIO $ do+ setALPN ctx MsgTEncryptedExtensions eexts+ modifyTLS13State ctx $ \st -> st{tls13stClientExtensions = eexts}+ st13 <- usingHState ctx getTLS13RTT0Status+ when (st13 == RTT0Sent) $+ case extensionLookup EID_EarlyData eexts of+ Just _ -> do+ usingHState ctx $ setTLS13HandshakeMode RTT0+ usingHState ctx $ setTLS13RTT0Status RTT0Accepted+ liftIO $ modifyTLS13State ctx $ \st -> st{tls13st0RTTAccepted = True}+ Nothing -> do+ usingHState ctx $ setTLS13HandshakeMode PreSharedKey+ usingHState ctx $ setTLS13RTT0Status RTT0Rejected+expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions")++----------------------------------------------------------------+-- not used in 0-RTT+expectCertRequest+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+expectCertRequest cparams ctx (CertRequest13 token exts) = do+ processCertRequest13 ctx token exts+ recvHandshake13 ctx $ expectCertAndVerify cparams ctx+expectCertRequest cparams ctx other = do+ usingHState ctx $ do+ setCertReqToken Nothing+ setCertReqCBdata Nothing+ -- setCertReqSigAlgsCert Nothing+ expectCertAndVerify cparams ctx other++processCertRequest13+ :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()+processCertRequest13 ctx token exts = do+ let hsextID = EID_SignatureAlgorithms+ -- caextID = EID_SignatureAlgorithmsCert+ dNames <- canames+ -- The @signature_algorithms@ extension is mandatory.+ hsAlgs <- extalgs hsextID unsighash+ cTypes <- case hsAlgs of+ Just as ->+ let validAs = filter isHashSignatureValid13 as+ in return $ sigAlgsToCertTypes ctx validAs+ 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+ Nothing -> return []+ Just ext -> case extensionDecode MsgTCertificateRequest ext of+ Just (CertificateAuthorities names) -> return names+ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure+ extalgs extID decons = case extensionLookup extID exts of+ Nothing -> return Nothing+ Just ext -> case extensionDecode MsgTCertificateRequest ext of+ Just e ->+ return $ decons e+ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure+ unsighash+ :: SignatureAlgorithms+ -> Maybe [HashAndSignatureAlgorithm]+ unsighash (SignatureAlgorithms a) = Just a++----------------------------------------------------------------+-- not used in 0-RTT+expectCertAndVerify+ :: 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 "CertVerify" $ expectCertVerify ctx pubkey++----------------------------------------------------------------++expectCertVerify+ :: 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 _ _ _ h = unexpected (show h) (Just "certificate verify")++----------------------------------------------------------------++expectFinished+ :: MonadIO m+ => ClientParams+ -> Context+ -> TranscriptHash+ -> Handshake13+ -> m ()+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")++----------------------------------------------------------------+----------------------------------------------------------------++sendClientSecondFlight13 :: ClientParams -> Context -> IO ()+sendClientSecondFlight13 cparams ctx = do+ st <- getTLS13State ctx+ let choice = tls13stChoice st+ hkey = fromJust $ tls13stHsKey st+ rtt0accepted = tls13st0RTTAccepted st+ 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+ -> Context+ -> CipherChoice+ -> SecretTriple HandshakeSecret+ -> Bool+ -> [ExtensionRaw]+ -> IO ()+sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts = do+ hChSf <- transcriptHash ctx "CH..SF"+ unless (ctxQUICMode ctx) $+ runPacketFlight ctx $+ sendChangeCipherSpec13 ctx+ when (rtt0accepted && not (ctxQUICMode ctx)) $+ sendPacket13 ctx (Handshake13 [EndOfEarlyData13] [])+ let clientHandshakeSecret = triClient hkey+ setTxRecordState ctx usedHash usedCipher clientHandshakeSecret+ sendClientFlight13 cparams ctx usedHash clientHandshakeSecret+ appKey <- switchToApplicationSecret hChSf+ let applicationSecret = triBase appKey+ setResumptionSecret applicationSecret+ let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey)+ contextSync ctx $ SendClientFinished eexts appSecInfo+ modifyTLS13State ctx $ \st -> st{tls13stHsKey = Nothing}+ finishHandshake13 ctx+ rtt0 <- tls13st0RTT <$> getTLS13State ctx+ when rtt0 $ do+ builder <- tls13stPendingSentData <$> getTLS13State ctx+ modifyTLS13State ctx $ \st -> st{tls13stPendingSentData = id}+ unless rtt0accepted $+ mapM_ (sendPacket13 ctx . AppData13) $+ builder []+ where+ usedCipher = cCipher choice+ usedHash = cHash choice++ switchToApplicationSecret hChSf = do+ ensureRecvComplete ctx+ let handshakeSecret = triBase hkey+ appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf+ let serverApplicationSecret0 = triServer appKey+ let clientApplicationSecret0 = triClient appKey+ setTxRecordState ctx usedHash usedCipher clientApplicationSecret0+ setRxRecordState ctx usedHash usedCipher serverApplicationSecret0+ return appKey++ setResumptionSecret applicationSecret = do+ resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret+ usingHState ctx $ setTLS13ResumptionSecret resumptionSecret++{- Unused for now+uncertsig :: SignatureAlgorithmsCert+ -> Maybe [HashAndSignatureAlgorithm]+uncertsig (SignatureAlgorithmsCert a) = Just a+-}++sendClientFlight13+ :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()+sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do+ mcc <- clientChain cparams ctx+ runPacketFlight ctx $ do+ case mcc of+ Nothing -> return ()+ Just cc -> do+ reqtoken <- usingHState ctx getCertReqToken+ certComp <- usingHState ctx getTLS13CertComp+ loadClientData13 cc reqtoken certComp+ rawFinished <- makeFinished ctx usedHash baseKey+ loadPacket13 ctx $ Handshake13 [rawFinished] []+ when (isJust mcc) $+ modifyTLS13State ctx $+ \st -> st{tls13stSentClientCert = True}+ where+ loadClientData13 chain (Just token) certComp = do+ let (CertificateChain certs) = chain+ certExts = replicate (length certs) []+ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx+ let certtag = if certComp then CompressedCertificate13 else Certificate13+ loadPacket13 ctx $+ Handshake13 [certtag token (CertificateChain_ chain) certExts] []+ case certs of+ [] -> return ()+ _ -> do+ 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] []+ --+ loadClientData13 _ _ _ =+ throwCore $+ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError++----------------------------------------------------------------+----------------------------------------------------------------++postHandshakeAuthClientWith+ :: ClientParams -> Context -> Handshake13 -> IO ()+postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) =+ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ -- updateTranscriptHash13 ctx h b+ processCertRequest13 ctx certReqCtx exts+ (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $+ Error_Protocol+ "unexpected post-handshake authentication request"+ UnexpectedMessage+ sendClientFlight13+ cparams+ ctx+ usedHash+ (ClientTrafficSecret applicationSecretN)+postHandshakeAuthClientWith _ _ _ =+ throwCore $+ Error_Protocol+ "unexpected handshake message received in postHandshakeAuthClientWith"+ UnexpectedMessage++----------------------------------------------------------------+----------------------------------------------------------------++asyncServerHello13+ :: ClientParams -> Context -> [Group] -> Millisecond -> IO ()+asyncServerHello13 cparams ctx groupSent chSentTime = do+ setPendingRecvActions+ ctx+ [ PendingRecvActionSelfUpdate True expectServerHello+ , PendingRecvAction True (expectEncryptedExtensions ctx)+ , PendingRecvActionHash True expectFinishedAndSet+ ]+ where+ 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 cparams ctx h sf+ liftIO $+ writeIORef (ctxPendingSendAction ctx) $+ Just $+ sendClientSecondFlight13 cparams
Network/TLS/Handshake/Common.hs view
@@ -1,253 +1,279 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-module Network.TLS.Handshake.Common- ( handshakeFailed- , handleException- , unexpected- , newSession- , handshakeTerminate++module Network.TLS.Handshake.Common (+ handshakeFailed,+ handleException,+ unexpected,+ newSession,+ ensureNullCompression,+ ticketOrSessionID12,+ -- * sending packets- , sendChangeCipherAndFinish+ sendCCSandFinished,+ -- * receiving packets- , recvChangeCipherAndFinish- , RecvState(..)- , runRecvState- , recvPacketHandshake- , onRecvStateHandshake- , ensureRecvComplete- , processExtendedMasterSec- , extensionLookup- , getSessionData- , storePrivInfo- , isSupportedGroup- , checkSupportedGroup- , errorToAlert- , errorToAlertMessage- ) where+ RecvState (..),+ runRecvState,+ runRecvStateHS,+ recvPacketHandshake,+ onRecvStateHandshake,+ ensureRecvComplete,+ processExtendedMainSecret,+ getSessionData,+ storePrivInfo,+ isSupportedGroup,+ checkSupportedGroup,+ errorToAlert,+ errorToAlertMessage,+ expectFinished,+ processCertificate,+ --+ setPeerRecordSizeLimit,+ generateFinished,+ encodeUpdateTranscriptHash12,+ updateTranscriptHash12,+ --+ startHandshake,+ finishHandshake12,+ setServerHelloParameters12,+) where -import qualified Data.ByteString as B import Control.Concurrent.MVar+import Control.Exception (IOException, fromException, handle, throwIO)+import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteString as B -import Network.TLS.Parameters+import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal+import Network.TLS.Crypto import Network.TLS.Extension-import Network.TLS.Session-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.IO-import Network.TLS.State import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process+import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State-import Network.TLS.Record.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+import Network.TLS.Struct13 import Network.TLS.Types-import Network.TLS.Cipher-import Network.TLS.Crypto import Network.TLS.Util import Network.TLS.X509-import Network.TLS.Imports -import Control.Monad.State.Strict-import Control.Exception (IOException, handle, fromException, throwIO)-import Data.IORef (writeIORef)- handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do- let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception+ 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+ Just e | Uncontextualized e' <- e -> e'+ _ -> Error_Misc (show exception)+ established <- ctxEstablished ctx setEstablished ctx NotEstablished handle ignoreIOErr $ do tls13 <- tls13orLater ctx- if tls13 then- sendPacket13 ctx $ Alert13 [errorToAlert tlserror]- else- sendPacket ctx $ Alert [errorToAlert tlserror]+ if tls13+ then do+ when (established == EarlyDataSending) $ clearTxRecordState ctx+ when (tlserror /= Error_TCP_Terminate) $+ sendPacket13 ctx $+ Alert13 [errorToAlert tlserror]+ else sendPacket12 ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where ignoreIOErr :: IOException -> IO () ignoreIOErr _ = return () errorToAlert :: TLSError -> (AlertLevel, AlertDescription)-errorToAlert (Error_Protocol (_, b, ad)) = let lvl = if b then AlertLevel_Fatal else AlertLevel_Warning- in (lvl, ad)+errorToAlert (Error_Protocol _ ad) = (AlertLevel_Fatal, ad)+errorToAlert (Error_Protocol_Warning _ ad) = (AlertLevel_Warning, ad) errorToAlert (Error_Packet_unexpected _ _) = (AlertLevel_Fatal, UnexpectedMessage) errorToAlert (Error_Packet_Parsing msg)- | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion)- | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter)- | otherwise = (AlertLevel_Fatal, DecodeError)-errorToAlert _ = (AlertLevel_Fatal, InternalError)+ | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion)+ | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter)+ | otherwise = (AlertLevel_Fatal, DecodeError)+errorToAlert _ = (AlertLevel_Fatal, InternalError) -- | Return the message that a TLS endpoint can add to its local log for the -- specified library error. errorToAlertMessage :: TLSError -> String-errorToAlertMessage (Error_Protocol (msg, _, _)) = msg+errorToAlertMessage (Error_Protocol msg _) = msg+errorToAlertMessage (Error_Protocol_Warning msg _) = msg errorToAlertMessage (Error_Packet_unexpected msg _) = msg-errorToAlertMessage (Error_Packet_Parsing msg) = msg-errorToAlertMessage e = show e+errorToAlertMessage (Error_Packet_Parsing msg) = msg+errorToAlertMessage e = show e unexpected :: MonadIO m => String -> Maybe String -> m a-unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)+unexpected msg expected =+ throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session newSession ctx | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32- | otherwise = return $ Session Nothing---- | when a new handshake is done, wrap up & clean up.-handshakeTerminate :: Context -> IO ()-handshakeTerminate ctx = do- session <- usingState_ ctx getSession- -- only callback the session established if we have a session- case session of- Session (Just sessionId) -> do- sessionData <- getSessionData ctx- let !sessionId' = B.copy sessionId- liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId' (fromJust "session-data" sessionData)- _ -> return ()- -- forget most handshake data and reset bytes counters.- liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake ->- case mhshake of- Nothing -> return Nothing- Just hshake ->- return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMasterSecret = hstMasterSecret hshake- , hstExtendedMasterSec = hstExtendedMasterSec hshake- , hstNegotiatedGroup = hstNegotiatedGroup hshake- }- updateMeasure ctx resetBytesCounters- -- mark the secure connection up and running.- setEstablished ctx Established- return ()--sendChangeCipherAndFinish :: Context- -> Role- -> IO ()-sendChangeCipherAndFinish ctx role = do- sendPacket ctx ChangeCipherSpec- liftIO $ contextFlush ctx- cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role- sendPacket ctx (Handshake [Finished cf])- writeIORef (ctxFinished ctx) $ Just cf- liftIO $ contextFlush ctx+ | otherwise = return $ Session Nothing -recvChangeCipherAndFinish :: Context -> IO ()-recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher)- where expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish- expectChangeCipher p = unexpected (show p) (Just "change cipher")- expectFinish (Finished _) = return RecvStateDone- expectFinish p = unexpected (show p) (Just "Handshake Finished")+sendCCSandFinished+ :: Context+ -> Role+ -> IO ()+sendCCSandFinished ctx role = do+ sendPacket12 ctx ChangeCipherSpec+ contextFlush ctx+ enablePeerRecordLimit ctx+ ver <- usingState_ ctx getVersion+ verifyData <- VerifyData <$> generateFinished ctx ver role+ sendPacket12 ctx (Handshake [Finished verifyData] [])+ usingState_ ctx $ setVerifyDataForSend verifyData+ contextFlush ctx -data RecvState m =- RecvStateNext (Packet -> m (RecvState m))+data RecvState m+ = RecvStatePacket (Packet -> m (RecvState m)) -- CCS is not Handshake | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake]+recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do- pkts <- recvPacket ctx+ 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. established <- ctxEstablished ctx case established of EarlyDataNotAllowed n- | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvPacketHandshake ctx- _ -> unexpected (show x) (Just "handshake")- Right x -> unexpected (show x) (Just "handshake")- Left err -> throwCore err+ | n > 0 -> do+ setEstablished ctx $ EarlyDataNotAllowed (n - 1)+ recvPacketHandshake ctx+ _ -> unexpected (show x) (Just "handshake")+ Right x -> unexpected (show x) (Just "handshake")+ Left err -> throwCore err -- | process a list of handshakes message in the recv state machine.-onRecvStateHandshake :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)-onRecvStateHandshake _ recvState [] = return recvState-onRecvStateHandshake _ (RecvStateNext f) hms = f (Handshake hms)-onRecvStateHandshake ctx (RecvStateHandshake f) (x:xs) = do- nstate <- f x- processHandshake ctx x- onRecvStateHandshake ctx nstate xs-onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing+onRecvStateHandshake+ :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO)+onRecvStateHandshake _ recvState [] = return recvState+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+isFinished _ = False+ runRecvState :: Context -> RecvState IO -> IO ()-runRecvState _ RecvStateDone = return ()-runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx-runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx+runRecvState _ RecvStateDone = return ()+runRecvState ctx (RecvStatePacket f) = recvPacket12 ctx >>= either throwCore f >>= runRecvState ctx+runRecvState ctx iniState =+ recvPacketHandshake ctx+ >>= onRecvStateHandshake ctx iniState+ >>= 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 complete <- liftIO $ isRecvComplete ctx unless complete $- throwCore $ Error_Protocol ("received incomplete message at key change", True, UnexpectedMessage)+ throwCore $+ Error_Protocol "received incomplete message at key change" UnexpectedMessage -processExtendedMasterSec :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool-processExtendedMasterSec ctx ver msgt exts- | ver < TLS10 = return False- | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3"+processExtendedMainSecret+ :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool+processExtendedMainSecret ctx ver msgt exts+ | ver < TLS10 = return False+ | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" | ems == NoEMS = return False- | otherwise =- case extensionLookup extensionID_ExtendedMasterSecret exts >>= extensionDecode msgt of- Just ExtendedMasterSecret -> usingHState ctx (setExtendedMasterSec True) >> return True- Nothing | ems == RequireEMS -> throwCore $ Error_Protocol (err, True, HandshakeFailure)- | otherwise -> return False- where ems = supportedExtendedMasterSec (ctxSupported ctx)- err = "peer does not support Extended Master Secret"+ | otherwise =+ liftIO $+ lookupAndDecodeAndDo+ EID_ExtendedMainSecret+ msgt+ exts+ nonExistAction+ existAction+ where+ 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 ver <- usingState_ ctx getVersion sni <- usingState_ ctx getClientSNI- mms <- usingHState ctx (gets hstMasterSecret)- !ems <- usingHState ctx getExtendedMasterSec- tx <- liftIO $ readMVar (ctxTxState ctx)+ mms <- usingHState ctx $ gets hstMainSecret+ ems <- usingHState ctx getExtendedMainSecret+ cipher <- cipherID <$> usingHState ctx getPendingCipher alpn <- usingState_ ctx getNegotiatedProtocol- let !cipher = cipherID $ fromJust "cipher" $ stCipher tx- !compression = compressionID $ stCompression tx+ let compression = 0 flags = [SessionEMS | ems] case mms of Nothing -> return Nothing- Just ms -> return $ Just SessionData- { sessionVersion = ver- , sessionCipher = cipher+ Just ms ->+ return $+ Just+ SessionData+ { sessionVersion = ver+ , sessionCipher = cipher , sessionCompression = compression- , sessionClientSNI = sni- , sessionSecret = ms- , sessionGroup = Nothing- , sessionTicketInfo = Nothing- , sessionALPN = alpn+ , sessionClientSNI = sni+ , sessionSecret = convert ms+ , sessionGroup = Nothing+ , sessionTicketInfo = Nothing+ , sessionALPN = alpn , sessionMaxEarlyDataSize = 0- , sessionFlags = flags+ , 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 -- types of keys match and that it does not include an algorithm that would -- not be safe.-storePrivInfo :: MonadIO m- => Context- -> CertificateChain- -> PrivKey- -> m PubKey+storePrivInfo+ :: MonadIO m+ => Context+ -> CertificateChain+ -> PrivKey+ -> m PubKey storePrivInfo ctx cc privkey = do- let CertificateChain (c:_) = cc+ let c = fromCC cc pubkey = certPubKey $ getCertificate c unless (isDigitalSignaturePair (pubkey, privkey)) $- throwCore $ Error_Protocol- ( "mismatched or unsupported private key pair"- , True- , InternalError )+ throwCore $+ Error_Protocol "mismatched or unsupported private key pair" InternalError usingHState ctx $ setPublicPrivateKeys (pubkey, privkey) return pubkey+ where+ fromCC (CertificateChain (c : _)) = c+ fromCC _ = error "fromCC" -- verify that the group selected by the peer is supported in the local -- configuration@@ -255,7 +281,162 @@ checkSupportedGroup ctx grp = unless (isSupportedGroup ctx grp) $ let msg = "unsupported (EC)DHE group: " ++ show grp- in throwCore $ Error_Protocol (msg, True, IllegalParameter)+ in throwCore $ Error_Protocol msg IllegalParameter isSupportedGroup :: Context -> Group -> Bool isSupportedGroup ctx grp = grp `elem` supportedGroups (ctxSupported ctx)++ensureNullCompression :: MonadIO m => CompressionID -> m ()+ensureNullCompression compression =+ when (compression /= compressionID nullCompression) $+ throwCore $+ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter++expectFinished :: Context -> Handshake -> IO (RecvState IO)+expectFinished ctx (Finished verifyData) = do+ processFinished ctx verifyData+ return RecvStateDone+expectFinished _ p = unexpected (show p) (Just "Handshake Finished")++processFinished :: Context -> VerifyData -> IO ()+processFinished ctx verifyData = do+ (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion+ expected <- VerifyData <$> generateFinished ctx ver (invertRole cc)+ when (expected /= verifyData) $ decryptError "finished verification failed"+ usingState_ ctx $ setVerifyDataForRecv verifyData++processCertificate :: Context -> Role -> CertificateChain -> IO ()+processCertificate _ ServerRole (CertificateChain []) = return ()+processCertificate _ ClientRole (CertificateChain []) =+ throwCore $ Error_Protocol "server certificate missing" HandshakeFailure+processCertificate ctx _ (CertificateChain (c : _)) =+ 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,135 +1,148 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} --- |--- Module : Network.TLS.Handshake.Common13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.Common13- ( makeFinished- , checkFinished- , makeServerKeyShare- , makeClientKeyShare- , fromServerKeyShare- , makeCertVerify- , checkCertVerify- , makePSKBinder- , replacePSKBinder- , sendChangeCipherSpec13- , handshakeTerminate13- , makeCertRequest- , createTLS13TicketInfo- , ageToObfuscatedAge- , isAgeValid- , getAge- , checkFreshness- , getCurrentTimeFromBase- , getSessionData13- , ensureNullCompression- , isHashSignatureValid13- , safeNonNegative32- , RecvHandshake13M- , runRecvHandshake13- , recvHandshake13- , recvHandshake13hash- , CipherChoice(..)- , makeCipherChoice- , initEarlySecret- , calculateEarlySecret- , calculateHandshakeSecret- , calculateApplicationSecret- , calculateResumptionSecret- , derivePSK- , checkKeyShareKeyLength- ) where+module Network.TLS.Handshake.Common13 (+ makeFinished,+ checkFinished,+ makeServerKeyShare,+ makeClientKeyShare,+ fromServerKeyShare,+ makeCertVerify,+ checkCertVerify,+ makePSKBinder,+ replacePSKBinder,+ sendChangeCipherSpec13,+ makeCertRequest,+ createTLS13TicketInfo,+ ageToObfuscatedAge,+ isAgeValid,+ getAge,+ checkFreshness,+ getCurrentTimeFromBase,+ getSessionData13,+ isHashSignatureValid13,+ safeNonNegative32,+ RecvHandshake13M,+ runRecvHandshake13,+ recvHandshake13,+ recvHandshake13hash,+ CipherChoice (..),+ makeCipherChoice,+ initEarlySecret,+ calculateEarlySecret,+ calculateHandshakeSecret,+ calculateApplicationSecret,+ calculateResumptionSecret,+ derivePSK,+ 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.Hourglass-import Network.TLS.Compression-import Network.TLS.Context.Internal+import Data.UnixTime+import Foreign.C.Types (CTime (..)) import Network.TLS.Cipher+import Network.TLS.Context.Internal 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.Process (processHandshake13) import Network.TLS.Handshake.Common (unexpected) import Network.TLS.Handshake.Key-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13 import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.State+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.IO import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire-import Time.System -import Control.Concurrent.MVar-import Control.Monad.State.Strict-import Data.IORef (writeIORef)- ---------------------------------------------------------------- -makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13+makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13 makeFinished ctx usedHash baseKey = do- finished <- makeVerifyData usedHash baseKey <$> transcriptHash ctx- liftIO $ writeIORef (ctxFinished ctx) (Just finished)- pure $ Finished13 finished+ 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- when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol ("broken Finished", True, DecodeError)- unless (verifyData' == verifyData) $ decryptError "cannot verify finished"- liftIO $ writeIORef (ctxPeerFinished ctx) (Just verifyData)+checkFinished+ :: 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 "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, True, IllegalParameter)- Right cpub -> do- ecdhePair <- generateECDHEShared ctx cpub- case ecdhePair of- Nothing -> throwCore $ Error_Protocol (msgInvalidPublic, True, IllegalParameter)- Just (spub, share) ->- let wspub = IES.encodeGroupPublic spub- serverKeyShare = KeyShareEntry grp wspub- in return (BA.convert share, serverKeyShare)+ Left e -> throwCore $ Error_Protocol (show e) IllegalParameter+ Right cpub -> do+ ecdhePair <- encapsulateGroup ctx cpub+ case ecdhePair of+ Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter+ Just (spub, share) ->+ let wspub = IES.groupEncodePublicB spub+ serverKeyShare = KeyShareEntry grp wspub+ 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- Left e -> throwCore $ Error_Protocol (show e, True, 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", True, IllegalParameter)+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 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 ---------------------------------------------------------------- @@ -139,24 +152,39 @@ clientContextString :: ByteString clientContextString = "TLS 1.3, client CertificateVerify" -makeCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Handshake13-makeCertVerify ctx pub hs hashValue = do- cc <- liftIO $ usingState_ ctx isClientContext- let ctxStr | cc == ClientRole = clientContextString- | otherwise = serverContextString+makeCertVerify+ :: MonadIO m+ => Context+ -> PubKey+ -> HashAndSignatureAlgorithm+ -> TranscriptHash+ -> m Handshake13+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 => Context -> PubKey -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool+checkCertVerify+ :: MonadIO m+ => Context+ -> PubKey+ -> HashAndSignatureAlgorithm+ -> Signature+ -> ByteString+ -> m Bool checkCertVerify ctx pub hs signature hashValue | pub `signatureCompatible13` hs = liftIO $ do- cc <- usingState_ ctx isClientContext- let ctxStr | cc == ClientRole = serverContextString -- opposite context- | otherwise = clientContextString+ role <- usingState_ ctx getRole+ let ctxStr+ | role == ClientRole = serverContextString -- opposite context+ | otherwise = clientContextString target = makeTarget ctxStr hashValue- sigParams = signatureParams pub (Just hs)+ sigParams = signatureParams pub hs checkHashSignatureValid13 hs- checkSupportedHashSignature ctx (Just hs)+ checkSupportedHashSignature ctx hs verifyPublic ctx sigParams target signature | otherwise = return False @@ -167,92 +195,85 @@ putWord8 0 putBytes hashValue -sign :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Signature+sign+ :: MonadIO m+ => Context+ -> PubKey+ -> HashAndSignatureAlgorithm+ -> ByteString+ -> m Signature sign ctx pub hs target = liftIO $ do- cc <- usingState_ ctx isClientContext- let sigParams = signatureParams pub (Just hs)- signPrivate ctx cc sigParams target+ role <- usingState_ ctx getRole+ let sigParams = signatureParams pub hs+ signPrivate ctx role sigParams target ---------------------------------------------------------------- -makePSKBinder :: Context -> 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+makePSKBinder+ :: BaseSecret EarlySecret+ -> Hash+ -> Int+ -> 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 ---------------------------------------------------------------- sendChangeCipherSpec13 :: Monoid b => Context -> PacketFlightM b () sendChangeCipherSpec13 ctx = do sent <- usingHState ctx $ do- b <- getCCS13Sent- unless b $ setCCS13Sent True- return b+ b <- getCCS13Sent+ unless b $ setCCS13Sent True+ return b unless sent $ loadPacket13 ctx ChangeCipherSpec13 ---------------------------------------------------------------- --- | TLS13 handshake wrap up & clean up. Contrary to @handshakeTerminate@, 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.-handshakeTerminate13 :: Context -> IO ()-handshakeTerminate13 ctx = do- -- forget most handshake data- liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake ->- case mhshake of- Nothing -> return Nothing- Just hshake ->- return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMasterSecret = hstMasterSecret hshake- , hstNegotiatedGroup = hstNegotiatedGroup 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 extensionID_CertificateAuthorities caDnsEncoded]- crexts = ExtensionRaw extensionID_SignatureAlgorithms sigAlgs : caExtension+ caExt+ | null caDns = Nothing+ | otherwise = Just $ toExtensionRaw $ CertificateAuthorities caDns++ crexts =+ catMaybes+ [ {- 0x0d -} signatureAlgExt+ , {- 0x1b -} compCertExt+ , {- 0x2f -} caExt+ ] in CertRequest13 certReqCtx crexts ---------------------------------------------------------------- -createTLS13TicketInfo :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo+createTLS13TicketInfo+ :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo createTLS13TicketInfo life ecw mrtt = do -- Left: serverSendTime -- Right: clientReceiveTime@@ -260,129 +281,148 @@ add <- case ecw of Left ctx -> B.foldl' (*+) 0 <$> getStateRNG ctx 4 Right ad -> return ad- return $ TLS13TicketInfo life add bTime mrtt+ return $+ TLS13TicketInfo+ { lifetime = life+ , ageAdd = add+ , txrxTime = bTime+ , estimatedRTT = mrtt+ } where x *+ y = x * 256 + fromIntegral y ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second-ageToObfuscatedAge age tinfo = obfage+ageToObfuscatedAge age TLS13TicketInfo{..} = obfage where- !obfage = age + ageAdd tinfo+ obfage = age + ageAdd obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second-obfuscatedAgeToAge obfage tinfo = age+obfuscatedAgeToAge obfage TLS13TicketInfo{..} = age where- !age = obfage - ageAdd tinfo+ age = obfage - ageAdd isAgeValid :: Second -> TLS13TicketInfo -> Bool-isAgeValid age tinfo = age <= lifetime tinfo * 1000+isAgeValid age TLS13TicketInfo{..} = age <= lifetime * 1000 getAge :: TLS13TicketInfo -> IO Second-getAge tinfo = do- let clientReceiveTime = txrxTime tinfo+getAge TLS13TicketInfo{..} = do+ let clientReceiveTime = txrxTime clientSendTime <- getCurrentTimeFromBase- return $! fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds+ return $ fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds checkFreshness :: TLS13TicketInfo -> Second -> IO Bool-checkFreshness tinfo obfAge = do+checkFreshness tinfo@TLS13TicketInfo{..} obfAge = do serverReceiveTime <- getCurrentTimeFromBase- let freshness = if expectedArrivalTime > serverReceiveTime- then expectedArrivalTime - serverReceiveTime- else serverReceiveTime - expectedArrivalTime+ let freshness =+ if expectedArrivalTime > serverReceiveTime+ then expectedArrivalTime - serverReceiveTime+ else serverReceiveTime - expectedArrivalTime -- Some implementations round age up to second. -- We take max of 2000 and rtt in the case where rtt is too small. let tolerance = max 2000 rtt isFresh = freshness < tolerance return $ isAlive && isFresh where- serverSendTime = txrxTime tinfo- Just rtt = estimatedRTT tinfo+ serverSendTime = txrxTime+ rtt = fromJust estimatedRTT age = obfuscatedAgeToAge obfAge tinfo expectedArrivalTime = serverSendTime + rtt + fromIntegral age isAlive = isAgeValid age tinfo getCurrentTimeFromBase :: IO Millisecond-getCurrentTimeFromBase = millisecondsFromBase <$> timeCurrentP+getCurrentTimeFromBase = millisecondsFromBase <$> getUnixTime -millisecondsFromBase :: ElapsedP -> Millisecond-millisecondsFromBase d = fromIntegral ms+millisecondsFromBase :: UnixTime -> Millisecond+millisecondsFromBase (UnixTime (CTime s) us) =+ fromIntegral ((s - base) * 1000) + fromIntegral (us `div` 1000) where- ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns) = d - timeConvert base- ms = s * 1000 + ns `div` 1000000- base = Date 2017 January 1+ base = 1483228800 +-- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT"+ ---------------------------------------------------------------- -getSessionData13 :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData+getSessionData13+ :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData getSessionData13 ctx usedCipher tinfo maxSize psk = do- ver <- usingState_ ctx getVersion+ ver <- usingState_ ctx getVersion malpn <- usingState_ ctx getNegotiatedProtocol- sni <- usingState_ ctx getClientSNI- mgrp <- usingHState ctx getNegotiatedGroup- return SessionData {- sessionVersion = ver- , sessionCipher = cipherID usedCipher- , sessionCompression = 0- , sessionClientSNI = sni- , sessionSecret = psk- , sessionGroup = mgrp- , sessionTicketInfo = Just tinfo- , sessionALPN = malpn- , sessionMaxEarlyDataSize = maxSize- , sessionFlags = []- }+ sni <- usingState_ ctx getClientSNI+ mgrp <- usingHState ctx getSupportedGroup+ return+ SessionData+ { sessionVersion = ver+ , sessionCipher = cipherID usedCipher+ , sessionCompression = 0+ , sessionClientSNI = sni+ , sessionSecret = psk+ , sessionGroup = mgrp+ , sessionTicketInfo = Just tinfo+ , sessionALPN = malpn+ , sessionMaxEarlyDataSize = maxSize+ , sessionFlags = []+ } ---------------------------------------------------------------- -ensureNullCompression :: MonadIO m => CompressionID -> m ()-ensureNullCompression compression =- when (compression /= compressionID nullCompression) $- throwCore $ Error_Protocol ("compression is not allowed in TLS 1.3", True, IllegalParameter)- -- Word32 is used in TLS 1.3 protocol. -- Int is used for API for Haskell TLS because it is natural. -- If Int is 64 bits, users can specify bigger number than Word32. -- If Int is 32 bits, 2^31 or larger may be converted into minus numbers. safeNonNegative32 :: (Num a, Ord a, FiniteBits a) => a -> a safeNonNegative32 x- | x <= 0 = 0- | finiteBitSize x <= 32 = x- | otherwise = x `min` fromIntegral (maxBound :: Word32)+ | x <= 0 = 0+ | finiteBitSize x <= 32 = x+ | otherwise = x `min` fromIntegral (maxBound :: Word32)+ ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)+newtype RecvHandshake13M m a+ = RecvHandshake13M (StateT [Handshake13R] m a) deriving (Functor, Applicative, Monad, MonadIO) -recvHandshake13 :: MonadIO m- => Context- -> (Handshake13 -> RecvHandshake13M m a)- -> RecvHandshake13M m a-recvHandshake13 ctx f = getHandshake13 ctx >>= f+recvHandshake13+ :: MonadIO m+ => Context+ -> (Handshake13 -> RecvHandshake13M m a)+ -> RecvHandshake13M m a+recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h -recvHandshake13hash :: MonadIO m- => Context- -> (ByteString -> Handshake13 -> RecvHandshake13M m a)- -> RecvHandshake13M m a-recvHandshake13hash ctx f = do- d <- transcriptHash ctx- getHandshake13 ctx >>= f d+recvHandshake13hash+ :: MonadIO m+ => Context+ -> String+ -> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a)+ -> RecvHandshake13M m a+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 x -> unexpected (show x) (Just "handshake 13")- Left err -> throwCore err+ 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 runRecvHandshake13 :: MonadIO m => RecvHandshake13M m a -> m a runRecvHandshake13 (RecvHandshake13M f) = do@@ -398,50 +438,41 @@ checkHashSignatureValid13 hs = unless (isHashSignatureValid13 hs) $ let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs- in throwCore $ Error_Protocol (msg, True, IllegalParameter)+ in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool+isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13++{- isHashSignatureValid13 (HashIntrinsic, s) =- s `elem` [ SignatureRSApssRSAeSHA256- , SignatureRSApssRSAeSHA384- , SignatureRSApssRSAeSHA512- , SignatureEd25519- , SignatureEd448- , SignatureRSApsspssSHA256- , SignatureRSApsspssSHA384- , SignatureRSApsspssSHA512- ]+ s+ `elem` [ SignatureRSApssRSAeSHA256+ , SignatureRSApssRSAeSHA384+ , SignatureRSApssRSAeSHA512+ , SignatureEd25519+ , SignatureEd448+ , SignatureRSApsspssSHA256+ , SignatureRSApsspssSHA384+ , SignatureRSApsspssSHA512+ ] isHashSignatureValid13 (h, SignatureECDSA) =- h `elem` [ HashSHA256, HashSHA384, HashSHA512 ]+ h `elem` [HashSHA256, HashSHA384, HashSHA512] isHashSignatureValid13 _ = False--data CipherChoice = CipherChoice {- cVersion :: Version- , cCipher :: Cipher- , cHash :: Hash- , cZero :: !ByteString- }--makeCipherChoice :: Version -> Cipher -> CipherChoice-makeCipherChoice ver cipher = CipherChoice ver cipher h zero- where- h = cipherHash cipher- zero = B.replicate (hashDigestSize h) 0+-} ---------------------------------------------------------------- -calculateEarlySecret :: 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+ :: Context+ -> CipherChoice+ -> Either ByteString (BaseSecret EarlySecret)+ -> IO (SecretPair EarlySecret)+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+ Right (BaseSecret sec) -> sec+ Left psk -> hkdfExtract usedHash zero (convert psk) clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets@@ -456,35 +487,57 @@ sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice- zeroOrPSK = case mpsk of- Just psk -> psk- Nothing -> zero+ zeroOrPSK = fromMaybe zero (convert <$> mpsk) -calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret -> ByteString- -> IO (SecretTriple HandshakeSecret)+calculateHandshakeSecret+ :: Context+ -> CipherChoice+ -> BaseSecret EarlySecret+ -> Secret+ -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do- hChSh <- transcriptHash ctx- let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) ecdhe- let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh- serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh- let shts = ServerTrafficSecret serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret- chts = ClientTrafficSecret clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret- logKey ctx shts- logKey ctx chts- return $ SecretTriple (BaseSecret handshakeSecret) chts shts+ hChSh <- transcriptHash ctx "CH..SH"+ let th = TranscriptHash $ hash usedHash ""+ handshakeSecret =+ hkdfExtract+ usedHash+ (deriveSecret usedHash sec "derived" th)+ ecdhe+ let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh+ serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh+ let shts =+ ServerTrafficSecret serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret+ chts =+ ClientTrafficSecret clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret+ logKey ctx shts+ logKey ctx chts+ return $ SecretTriple (BaseSecret handshakeSecret) chts shts where usedHash = cHash choice -calculateApplicationSecret :: Context -> CipherChoice -> BaseSecret HandshakeSecret -> ByteString- -> IO (SecretTriple ApplicationSecret)+calculateApplicationSecret+ :: Context+ -> CipherChoice+ -> BaseSecret HandshakeSecret+ -> TranscriptHash+ -> IO (SecretTriple ApplicationSecret) calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do- let applicationSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) zero+ let th = TranscriptHash $ hash usedHash ""+ applicationSecret =+ hkdfExtract+ usedHash+ (deriveSecret usedHash sec "derived" th)+ zero let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf- exporterMasterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf- usingState_ ctx $ setExporterMasterSecret exporterMasterSecret- let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret- let cts0 = ClientTrafficSecret clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret+ exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf+ usingState_ ctx $ setTLS13ExporterSecret exporterSecret+ let sts0 =+ ServerTrafficSecret serverApplicationSecret0+ :: ServerTrafficSecret ApplicationSecret+ let cts0 =+ ClientTrafficSecret clientApplicationSecret0+ :: ClientTrafficSecret ApplicationSecret logKey ctx sts0 logKey ctx cts0 return $ SecretTriple (BaseSecret applicationSecret) cts0 sts0@@ -492,17 +545,21 @@ usedHash = cHash choice zero = cZero choice -calculateResumptionSecret :: Context -> CipherChoice -> BaseSecret ApplicationSecret- -> IO (BaseSecret ResumptionSecret)+calculateResumptionSecret+ :: Context+ -> CipherChoice+ -> BaseSecret ApplicationSecret+ -> IO (BaseSecret ResumptionSecret) calculateResumptionSecret ctx choice (BaseSecret sec) = do- hChCf <- transcriptHash ctx- let resumptionMasterSecret = deriveSecret usedHash sec "res master" hChCf- return $ BaseSecret resumptionMasterSecret+ 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 =+derivePSK+ :: CipherChoice -> BaseSecret ResumptionSecret -> TicketNonce -> ByteString+derivePSK choice (BaseSecret sec) (TicketNonce nonce) = hkdfExpandLabel usedHash sec "resumption" nonce hashSize where usedHash = cHash choice@@ -510,20 +567,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+{- 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
@@ -1,18 +1,11 @@--- |--- Module : Network.TLS.Handshake.Control--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown--- module Network.TLS.Handshake.Control (- ClientState(..)- , ServerState(..)- , EarlySecretInfo(..)- , HandshakeSecretInfo(..)- , ApplicationSecretInfo(..)- , NegotiatedProtocol- ) where+ ClientState (..),+ ServerState (..),+ EarlySecretInfo (..),+ HandshakeSecretInfo (..),+ ApplicationSecretInfo (..),+ NegotiatedProtocol,+) where import Network.TLS.Cipher import Network.TLS.Imports@@ -27,23 +20,24 @@ -- | Handshake information generated for traffic at 0-RTT level. data EarlySecretInfo = EarlySecretInfo Cipher (ClientTrafficSecret EarlySecret)- deriving Show+ deriving (Show) -- | Handshake information generated for traffic at handshake level.-data HandshakeSecretInfo = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret)- deriving Show+data HandshakeSecretInfo+ = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret)+ deriving (Show) -- | Handshake information generated for traffic at application level. newtype ApplicationSecretInfo = ApplicationSecretInfo (TrafficSecrets ApplicationSecret)- deriving Show+ deriving (Show) ---------------------------------------------------------------- -data ClientState =- SendClientHello (Maybe EarlySecretInfo)- | RecvServerHello HandshakeSecretInfo- | SendClientFinished [ExtensionRaw] ApplicationSecretInfo+data ClientState+ = SendClientHello (Maybe EarlySecretInfo)+ | RecvServerHello HandshakeSecretInfo+ | SendClientFinished [ExtensionRaw] ApplicationSecretInfo -data ServerState =- SendServerHello [ExtensionRaw] (Maybe EarlySecretInfo) HandshakeSecretInfo- | SendServerFinished ApplicationSecretInfo+data ServerState+ = SendServerHello [ExtensionRaw] (Maybe EarlySecretInfo) HandshakeSecretInfo+ | SendServerFinished ApplicationSecretInfo
Network/TLS/Handshake/Key.hs view
@@ -1,54 +1,48 @@ {-# LANGUAGE FlexibleInstances #-}--- |--- Module : Network.TLS.Handshake.Key--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ functions for RSA operations----module Network.TLS.Handshake.Key- ( encryptRSA- , signPrivate- , decryptRSA- , verifyPublic- , generateDHE- , generateECDHE- , generateECDHEShared- , generateFFDHE- , generateFFDHEShared- , versionCompatible- , isDigitalSignaturePair- , checkDigitalSignatureKey- , getLocalPublicKey- , satisfiesEcPredicate- , logKey- ) where -import Control.Monad.State.Strict+-- | Functions for RSA operations+module Network.TLS.Handshake.Key (+ encryptRSA,+ signPrivate,+ decryptRSA,+ verifyPublic,+ generateDHE,+ generateGroup,+ encapsulateGroup,+ generateFFDHE,+ generateFFDHEShared,+ versionCompatible,+ isDigitalSignaturePair,+ checkDigitalSignatureKey,+ getLocalPublicKey,+ satisfiesEcPredicate,+ logKey,+) where +import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B -import Network.TLS.Handshake.State-import Network.TLS.State (withRNG, getVersion)-import Network.TLS.Crypto-import Network.TLS.Types 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 import Network.TLS.X509 {- 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 v <- withRNG $ kxEncrypt publicKey content case v of- Left err -> error ("rsa encrypt failed: " ++ show err)+ Left err -> error ("rsa encrypt failed: " ++ show err) Right econtent -> return econtent signPrivate :: Context -> Role -> SignatureParams -> ByteString -> IO ByteString@@ -57,18 +51,18 @@ usingState_ ctx $ do r <- withRNG $ kxSign privateKey publicKey params content case r of- Left err -> error ("sign failed: " ++ show err)+ 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- ver <- getVersion- let cipher = if ver < TLS10 then econtent else B.drop 2 econtent+ let cipher = B.drop 2 econtent withRNG $ kxDecrypt privateKey cipher -verifyPublic :: Context -> SignatureParams -> ByteString -> ByteString -> IO Bool+verifyPublic+ :: Context -> SignatureParams -> ByteString -> ByteString -> IO Bool verifyPublic ctx params econtent sign = do publicKey <- usingHState ctx getRemotePublicKey return $ kxVerify publicKey params econtent sign@@ -76,33 +70,37 @@ 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 -generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey))+generateFFDHEShared+ :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub +{- FOURMOLU_DISABLE -} isDigitalSignatureKey :: PubKey -> Bool-isDigitalSignatureKey (PubKeyRSA _) = True-isDigitalSignatureKey (PubKeyDSA _) = True-isDigitalSignatureKey (PubKeyEC _) = True-isDigitalSignatureKey (PubKeyEd25519 _) = True-isDigitalSignatureKey (PubKeyEd448 _) = True-isDigitalSignatureKey _ = False+isDigitalSignatureKey (PubKeyRSA _) = True+isDigitalSignatureKey (PubKeyDSA _) = True+isDigitalSignatureKey (PubKeyEC _) = True+isDigitalSignatureKey (PubKeyEd25519 _) = True+isDigitalSignatureKey (PubKeyEd448 _) = True+isDigitalSignatureKey _ = False versionCompatible :: PubKey -> Version -> Bool-versionCompatible (PubKeyRSA _) _ = True-versionCompatible (PubKeyDSA _) v = v <= TLS12-versionCompatible (PubKeyEC _) v = v >= TLS10-versionCompatible (PubKeyEd25519 _) v = v >= TLS12-versionCompatible (PubKeyEd448 _) v = v >= TLS12-versionCompatible _ _ = False+versionCompatible (PubKeyRSA _) _ = True+versionCompatible (PubKeyDSA _) v = v <= TLS12+versionCompatible (PubKeyEC _) v = v >= TLS10+versionCompatible (PubKeyEd25519 _) v = v >= TLS12+versionCompatible (PubKeyEd448 _) v = v >= TLS12+versionCompatible _ _ = False+{- FOURMOLU_ENABLE -} -- | Test whether the argument is a public key supported for signature at the -- specified TLS version. This also accepts a key for RSA encryption. This@@ -111,9 +109,13 @@ checkDigitalSignatureKey :: MonadIO m => Version -> PubKey -> m () checkDigitalSignatureKey usedVersion key = do unless (isDigitalSignatureKey key) $- throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)+ throwCore $+ Error_Protocol "unsupported remote public key type" HandshakeFailure unless (key `versionCompatible` usedVersion) $- throwCore $ Error_Protocol (show usedVersion ++ " has no support for " ++ pubkeyType key, True, IllegalParameter)+ throwCore $+ Error_Protocol+ (show usedVersion ++ " has no support for " ++ pubkeyType key)+ IllegalParameter -- | Test whether the argument is matching key pair supported for signature. -- This also accepts material for RSA encryption. This test is performed by@@ -121,12 +123,12 @@ isDigitalSignaturePair :: (PubKey, PrivKey) -> Bool isDigitalSignaturePair keyPair = case keyPair of- (PubKeyRSA _, PrivKeyRSA _) -> True- (PubKeyDSA _, PrivKeyDSA _) -> True- (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k- (PubKeyEd25519 _, PrivKeyEd25519 _) -> True- (PubKeyEd448 _, PrivKeyEd448 _) -> True- _ -> False+ (PubKeyRSA _, PrivKeyRSA _) -> True+ (PubKeyDSA _, PrivKeyDSA _) -> True+ (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k+ (PubKeyEd25519 _, PrivKeyEd25519 _) -> True+ (PubKeyEd448 _, PrivKeyEd448 _) -> True+ _ -> False getLocalPublicKey :: MonadIO m => Context -> m PubKey getLocalPublicKey ctx =@@ -138,15 +140,15 @@ satisfiesEcPredicate :: (Group -> Bool) -> PubKey -> Bool satisfiesEcPredicate p (PubKeyEC ecPub) = maybe False p $ findEllipticCurveGroup ecPub-satisfiesEcPredicate _ _ = True+satisfiesEcPredicate _ _ = True ---------------------------------------------------------------- class LogLabel a where- labelAndKey :: a -> (String, ByteString)+ labelAndKey :: a -> (String, Secret) -instance LogLabel MasterSecret where- labelAndKey (MasterSecret key) = ("CLIENT_RANDOM", key)+instance LogLabel MainSecret where+ labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key) instance LogLabel (ClientTrafficSecret EarlySecret) where labelAndKey (ClientTrafficSecret key) = ("CLIENT_EARLY_TRAFFIC_SECRET", key)@@ -169,10 +171,12 @@ logKey ctx logkey = do mhst <- getHState ctx case mhst of- Nothing -> return ()- Just hst -> do- let cr = unClientRandom $ hstClientRandom hst- (label,key) = labelAndKey logkey- ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key+ Nothing -> return ()+ Just hst -> do+ let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst)+ cr = unClientRandom crm+ (label, key) = labelAndKey logkey+ 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,146 +0,0 @@--- |--- Module : Network.TLS.Handshake.Process--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ process handshake message received----module Network.TLS.Handshake.Process- ( processHandshake- , processHandshake13- , startHandshake- ) where--import Network.TLS.Context.Internal-import Network.TLS.Crypto-import Network.TLS.ErrT-import Network.TLS.Extension-import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.Signature-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Parameters-import Network.TLS.Sending-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types (Role(..), invertRole, MasterSecret(..))-import Network.TLS.Util--import Control.Concurrent.MVar-import Control.Monad.IO.Class (liftIO)-import Control.Monad.State.Strict (gets)-import Data.X509 (CertificateChain(..), Certificate(..), getCertificate)-import Data.IORef (writeIORef)--processHandshake :: Context -> Handshake -> IO ()-processHandshake ctx hs = do- role <- usingState_ ctx isClientContext- case hs of- ClientHello cver ran _ cids _ ex _ -> when (role == ServerRole) $ do- mapM_ (usingState_ ctx . processClientExtension) ex- -- RFC 5746: secure renegotiation- -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}- when (secureRenegotiation && (0xff `elem` cids)) $- usingState_ ctx $ setSecureRenegotiation True- hrr <- usingState_ ctx getTLS13HRR- unless hrr $ startHandshake ctx cver ran- Certificates certs -> processCertificates role certs- Finished fdata -> processClientFinished ctx fdata- _ -> return ()- when (isHRR hs) $ usingHState ctx wrapAsMessageHash13- void $ updateHandshake ctx ServerRole hs- case hs of- ClientKeyXchg content -> when (role == ServerRole) $- processClientKeyXchg ctx content- _ -> return ()- where secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx- -- RFC5746: secure renegotiation- -- the renegotiation_info extension: 0xff01- processClientExtension (ExtensionRaw 0xff01 content) | secureRenegotiation = do- v <- getVerifiedData ClientRole- let bs = extensionEncode (SecureRenegotiation v Nothing)- unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure)-- setSecureRenegotiation True- -- unknown extensions- processClientExtension _ = return ()-- processCertificates :: Role -> CertificateChain -> IO ()- processCertificates ServerRole (CertificateChain []) = return ()- processCertificates ClientRole (CertificateChain []) =- throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure)- processCertificates _ (CertificateChain (c:_)) =- usingHState ctx $ setPublicKey pubkey- where pubkey = certPubKey $ getCertificate c-- isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand- isHRR _ = False--processHandshake13 :: Context -> Handshake13 -> IO ()-processHandshake13 ctx = void . updateHandshake13 ctx---- process the client key exchange message. the protocol expects the initial--- client version received in ClientHello, not the negotiated version.--- in case the version mismatch, generate a random master secret-processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO ()-processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do- (rver, role, random) <- usingState_ ctx $ do- (,,) <$> getVersion <*> isClientContext <*> genRandom 48- ePremaster <- decryptRSA ctx encryptedPremaster- masterSecret <- usingHState ctx $ do- expectedVer <- gets hstClientVersion- case ePremaster of- Left _ -> setMasterSecretFromPre rver role random- Right premaster -> case decodePreMasterSecret premaster of- Left _ -> setMasterSecretFromPre rver role random- Right (ver, _)- | ver /= expectedVer -> setMasterSecretFromPre rver role random- | otherwise -> setMasterSecretFromPre rver role premaster- liftIO $ logKey ctx (MasterSecret masterSecret)--processClientKeyXchg ctx (CKX_DH clientDHValue) = do- rver <- usingState_ ctx getVersion- role <- usingState_ ctx isClientContext-- serverParams <- usingHState ctx getServerDHParams- let params = serverDHParamsToParams serverParams- unless (dhValid params $ dhUnwrapPublic clientDHValue) $- throwCore $ Error_Protocol ("invalid client public key", True, IllegalParameter)-- dhpriv <- usingHState ctx getDHPrivate- let premaster = dhGetShared params dhpriv clientDHValue- masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster- liftIO $ logKey ctx (MasterSecret masterSecret)--processClientKeyXchg ctx (CKX_ECDH bytes) = do- ServerECDHParams grp _ <- usingHState ctx getServerECDHParams- case decodeGroupPublic grp bytes of- Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, IllegalParameter)- Right clipub -> do- srvpri <- usingHState ctx getGroupPrivate- case groupGetShared clipub srvpri of- Just premaster -> do- rver <- usingState_ ctx getVersion- role <- usingState_ ctx isClientContext- masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster- liftIO $ logKey ctx (MasterSecret masterSecret)- Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on ECDH", True, IllegalParameter)--processClientFinished :: Context -> FinishedData -> IO ()-processClientFinished ctx fdata = do- (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion- expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc- when (expected /= fdata) $ decryptError "cannot verify finished"- writeIORef (ctxPeerFinished ctx) $ Just fdata---- 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 liftIO $ void $ swapMVar (ctxHandshake ctx) hs
Network/TLS/Handshake/Random.hs view
@@ -1,21 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}--- |--- Module : Network.TLS.Handshake.Random--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown---+ module Network.TLS.Handshake.Random (- serverRandom- , clientRandom- , hrrRandom- , isHelloRetryRequest- , isDowngraded- ) where+ serverRandom,+ serverRandomECH,+ replaceServerRandomECH,+ clientRandom,+ 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@@ -28,47 +25,49 @@ -- consequence of our debug API allowing this). serverRandom :: Context -> Version -> [Version] -> IO ServerRandom serverRandom ctx chosenVer suppVers- | TLS13 `elem` suppVers = case chosenVer of- TLS13 -> ServerRandom <$> getStateRNG ctx 32- TLS12 -> ServerRandom <$> genServRand suffix12- _ -> ServerRandom <$> genServRand suffix11- | TLS12 `elem` suppVers = case chosenVer of- TLS13 -> ServerRandom <$> getStateRNG ctx 32- TLS12 -> ServerRandom <$> getStateRNG ctx 32- _ -> ServerRandom <$> genServRand suffix11- | otherwise = ServerRandom <$> getStateRNG ctx 32+ | TLS13 `elem` suppVers = case chosenVer of+ TLS13 -> ServerRandom <$> getStateRNG ctx 32+ TLS12 -> ServerRandom <$> genServRand suffix12+ _ -> ServerRandom <$> genServRand suffix11+ | TLS12 `elem` suppVers = case chosenVer of+ TLS13 -> ServerRandom <$> getStateRNG ctx 32+ TLS12 -> ServerRandom <$> getStateRNG ctx 32+ _ -> ServerRandom <$> genServRand suffix11+ | otherwise = ServerRandom <$> getStateRNG ctx 32 where genServRand suff = do 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 isDowngraded ver suppVers (ServerRandom sr)- | ver <= TLS12- , TLS13 `elem` suppVers = suffix12 `B.isSuffixOf` sr- || suffix11 `B.isSuffixOf` sr- | ver <= TLS11- , TLS12 `elem` suppVers = suffix11 `B.isSuffixOf` sr- | otherwise = False+ | ver <= TLS12+ , TLS13 `elem` suppVers =+ suffix12 `B.isSuffixOf` sr+ || suffix11 `B.isSuffixOf` sr+ | ver <= TLS11+ , TLS12 `elem` suppVers =+ 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
@@ -1,1214 +1,89 @@ {-# LANGUAGE OverloadedStrings #-}--- |--- Module : Network.TLS.Handshake.Server--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.Server- ( handshakeServer- , handshakeServerWith- , requestCertificateServer- , postHandshakeAuthServerWith- ) where--import Network.TLS.Parameters-import Network.TLS.Imports-import Network.TLS.Context.Internal-import Network.TLS.Session-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Credentials-import Network.TLS.Crypto-import Network.TLS.Extension-import Network.TLS.Util (bytesEq, catchException, fromJust)-import Network.TLS.IO-import Network.TLS.Types-import Network.TLS.State-import Network.TLS.Handshake.Control-import Network.TLS.Handshake.State-import Network.TLS.Handshake.Process-import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Random-import Network.TLS.Measurement-import qualified Data.ByteString as B-import Data.X509 (ExtKeyUsageFlag(..))--import Control.Monad.State.Strict-import Control.Exception (bracket)--import Network.TLS.Handshake.Signature-import Network.TLS.Handshake.Common-import Network.TLS.Handshake.Certificate-import Network.TLS.X509-import Network.TLS.Handshake.State13-import Network.TLS.Handshake.Common13---- Put the server context in handshake mode.------ Expect to receive as first packet a client hello handshake message------ This is just a helper to pop the next message from the recv layer,--- and call handshakeServerWith.-handshakeServer :: ServerParams -> Context -> IO ()-handshakeServer sparams ctx = liftIO $ do- hss <- recvPacketHandshake ctx- case hss of- [ch] -> handshakeServerWith sparams ctx ch- _ -> unexpected (show hss) (Just "client hello")---- | 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.------ When the function returns, a new handshake has been succesfully negociated.--- On any error, a HandshakeFailed exception is raised.------ handshake protocol (<- receiving, -> sending, [] optional):--- (no session) (session resumption)--- <- client hello <- client hello--- -> server hello -> server hello--- -> [certificate]--- -> [server key xchg]--- -> [cert request]--- -> hello done--- <- [certificate]--- <- client key xchg--- <- [cert verify]--- <- change cipher -> change cipher--- <- finish -> finish--- -> change cipher <- change cipher--- -> finish <- finish----handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()-handshakeServerWith sparams ctx clientHello@(ClientHello legacyVersion _ clientSession ciphers compressions exts _) = do- established <- ctxEstablished ctx- -- renego is not allowed in TLS 1.3- when (established /= NotEstablished) $ do- ver <- usingState_ ctx (getVersionWithDefault TLS10)- when (ver == TLS13) $ throwCore $ Error_Protocol ("renegotiation is not allowed in TLS 1.3", True, UnexpectedMessage)- -- rejecting client initiated renegotiation to prevent DOS.- eof <- ctxEOF ctx- let renegotiation = established == Established && not eof- when (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $- throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation)- -- check if policy allow this new handshake to happens- handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)- unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")- updateMeasure ctx incrementNbHandshakes-- -- Handle Client hello- processHandshake ctx clientHello-- -- rejecting SSL2. RFC 6176- when (legacyVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion)- -- rejecting SSL3. RFC 7568- when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion)-- -- Fallback SCSV: RFC7507- -- TLS_FALLBACK_SCSV: {0x56, 0x00}- when (supportedFallbackScsv (ctxSupported ctx) &&- (0x5600 `elem` ciphers) &&- legacyVersion < TLS12) $- throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback)- -- choosing TLS version- let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of- Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == []- _ -> []- clientVersion = min TLS12 legacyVersion- serverVersions- | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx)- | otherwise = supportedVersions $ ctxSupported ctx- mVersion = debugVersionForced $ serverDebug sparams- chosenVersion <- case mVersion of- Just cver -> return cver- Nothing ->- if (TLS13 `elem` serverVersions) && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of- Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion)- Just v -> return v- else case findHighestVersionFrom clientVersion serverVersions of- Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion)- Just v -> return v-- -- SNI (Server Name Indication)- let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode MsgTClientHello of- Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns)- where toHostName (ServerNameHostName hostName) = Just hostName- toHostName (ServerNameOther _) = Nothing- _ -> Nothing- maybe (return ()) (usingState_ ctx . setClientSNI) serverName-- -- TLS version dependent- if chosenVersion <= TLS12 then- handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession- else do- mapM_ ensureNullCompression compressions- -- fixme: we should check if the client random is the same as- -- that in the first client hello in the case of hello retry.- handshakeServerWithTLS13 sparams ctx chosenVersion exts ciphers serverName clientSession-handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure)---- TLS 1.2 or earlier-handshakeServerWithTLS12 :: ServerParams- -> Context- -> Version- -> [ExtensionRaw]- -> [CipherID]- -> Maybe String- -> Version- -> [CompressionID]- -> Session- -> IO ()-handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession = do- extraCreds <- onServerNameIndication (serverHooks sparams) serverName- let allCreds = filterCredentials (isCredentialAllowed chosenVersion exts) $- extraCreds `mappend` sharedCredentials (ctxShared ctx)-- -- If compression is null, commonCompressions should be [0].- when (null commonCompressions) $ throwCore $- Error_Protocol ("no compression in common with the client", True, HandshakeFailure)-- -- When selecting a cipher we must ensure that it is allowed for the- -- TLS version but also that all its key-exchange requirements- -- will be met.-- -- Some ciphers require a signature and a hash. With TLS 1.2 the hash- -- algorithm is selected from a combination of server configuration and- -- the client "supported_signatures" extension. So we cannot pick- -- such a cipher if no hash is available for it. It's best to skip this- -- cipher and pick another one (with another key exchange).-- -- 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- -- the resulting credentials.-- let possibleGroups = negotiatedGroupsInCommon ctx exts- possibleECGroups = possibleGroups `intersect` availableECGroups- possibleFFGroups = possibleGroups `intersect` availableFFGroups- hasCommonGroupForECDHE = not (null possibleECGroups)- hasCommonGroupForFFDHE = not (null possibleFFGroups)- hasCustomGroupForFFDHE = isJust (serverDHEParams sparams)- canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE- hasCommonGroup cipher =- case cipherKeyExchange cipher of- CipherKeyExchange_DH_Anon -> canFFDHE- CipherKeyExchange_DHE_RSA -> canFFDHE- CipherKeyExchange_DHE_DSS -> canFFDHE- CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE- CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE- _ -> True -- group not used-- -- Ciphers are selected according to TLS version, availability of- -- (EC)DHE group and credential depending on key exchange.- cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher- selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials)-- (creds, signatureCreds, ciphersFilteredVersion)- = case chosenVersion of- TLS12 -> let -- Build a list of all hash/signature algorithms in common between- -- client and server.- possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts-- -- Check that a candidate signature credential will be compatible with- -- client & server hash/signature algorithms. This returns Just Int- -- in order to sort credentials according to server hash/signature- -- preference. When the certificate has no matching hash/signature in- -- 'possibleHashSigAlgs' the result is Nothing, and the credential will- -- not be used to sign. This avoids a failure later in 'decideHashSig'.- signingRank cred =- case credentialDigitalSignatureKey cred of- Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs- Nothing -> Nothing-- -- Finally compute credential lists and resulting cipher list.- --- -- 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 RFC 8446 section 4.4.2.2).- -- The condition is based on resulting (EC)DHE ciphers so that- -- filtering credentials does not give advantage to a less secure- -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon.- cltCreds = filterCredentialsWithHashSignatures exts allCreds- sigCltCreds = filterSortCredentials signingRank cltCreds- sigAllCreds = filterSortCredentials signingRank allCreds- cltCiphers = selectCipher cltCreds sigCltCreds- allCiphers = selectCipher allCreds sigAllCreds-- resultTuple = if cipherListCredentialFallback cltCiphers- then (allCreds, sigAllCreds, allCiphers)- else (cltCreds, sigCltCreds, cltCiphers)- in resultTuple- _ ->- let sigAllCreds = filterCredentials (isJust . credentialDigitalSignatureKey) allCreds- allCiphers = selectCipher allCreds sigAllCreds- in (allCreds, sigAllCreds, allCiphers)-- -- 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) $ throwCore $- Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)-- let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion-- cred <- case cipherKeyExchange usedCipher of- CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds- CipherKeyExchange_DH_Anon -> return Nothing- CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds- CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning KX_DSS signatureCreds- CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds- CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds- _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure)-- ems <- processExtendedMasterSec ctx chosenVersion MsgTClientHello exts- resumeSessionData <- case clientSession of- (Session (Just clientSessionId)) -> do- let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId- resume >>= validateSession serverName ems- (Session Nothing) -> return Nothing-- -- Currently, we don't send back EcPointFormats. In this case,- -- the client chooses EcPointFormat_Uncompressed.- case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode MsgTClientHello of- Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs- _ -> return ()-- doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts-- where- commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds)- commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions- usedCompression = head commonCompressions-- validateSession _ _ Nothing = return Nothing- validateSession 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.- | clientVersion < sessionVersion sd = return Nothing- | sessionCipher sd `notElem` ciphers = return Nothing- | sessionCompression sd `notElem` compressions = return Nothing- | isJust sni && sessionClientSNI sd /= sni = return Nothing- | ems && not emsSession = return Nothing- | not ems && emsSession =- let err = "client resumes an EMS session without EMS"- in throwCore $ Error_Protocol (err, True, HandshakeFailure)- | otherwise = return m- where emsSession = SessionEMS `elem` sessionFlags sd--doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher- -> Compression -> Session -> Maybe SessionData- -> [ExtensionRaw] -> IO ()-doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do- case resumeSessionData of- Nothing -> do- handshakeSendServerData- liftIO $ contextFlush ctx- -- Receive client info until client Finished.- recvClientData sparams ctx- sendChangeCipherAndFinish ctx ServerRole- Just sessionData -> do- usingState_ ctx (setSession clientSession True)- serverhello <- makeServerHello clientSession- sendPacket ctx $ Handshake [serverhello]- let masterSecret = sessionSecret sessionData- usingHState ctx $ setMasterSecret chosenVersion ServerRole masterSecret- logKey ctx (MasterSecret masterSecret)- sendChangeCipherAndFinish ctx ServerRole- recvChangeCipherAndFinish ctx- handshakeTerminate ctx- where- ---- -- When the client sends a certificate, check whether- -- it is acceptable for the application.- --- ---- makeServerHello session = do- srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams- 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- vf <- usingState_ ctx $ do- cvf <- getVerifiedData ClientRole- svf <- getVerifiedData ServerRole- return $ extensionEncode (SecureRenegotiation cvf $ Just svf)- return [ ExtensionRaw extensionID_SecureRenegotiation vf ]- else return []- ems <- usingHState ctx getExtendedMasterSec- let emsExt | ems = let raw = extensionEncode ExtendedMasterSecret- in [ ExtensionRaw extensionID_ExtendedMasterSecret raw ]- | otherwise = []- protoExt <- applicationProtocol ctx exts sparams- sniExt <- do- resuming <- usingState_ ctx isSessionResuming- if resuming- then return []- else do- msni <- usingState_ ctx getClientSNI- 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 _ -> return [ ExtensionRaw extensionID_ServerName ""]- Nothing -> return []- let extensions = sharedHelloExtensions (serverShared sparams)- ++ secRengExt ++ emsExt ++ protoExt ++ sniExt- usingState_ ctx (setVersion chosenVersion)- usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression- return $ ServerHello chosenVersion srand session (cipherID usedCipher)- (compressionID usedCompression) extensions-- handshakeSendServerData = do- serverSession <- newSession ctx- usingState_ ctx (setSession serverSession False)- serverhello <- makeServerHello serverSession- -- send ServerHello & Certificate & ServerKeyXchg & CertReq- let certMsg = case mcred of- Just (srvCerts, _) -> Certificates srvCerts- _ -> Certificates $ CertificateChain []- sendPacket ctx $ Handshake [ serverhello, certMsg ]-- -- send server key exchange if needed- skx <- case cipherKeyExchange usedCipher of- CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon- CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA- CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE KX_DSS- CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA- CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA- _ -> return Nothing- maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx-- -- FIXME we don't do this on a Anonymous server-- -- When configured, send a certificate request with the DNs of all- -- configured CA certificates.- --- -- Client certificates MUST NOT be accepted if not requested.- --- when (serverWantClientCert sparams) $ do- usedVersion <- usingState_ ctx getVersion- let defaultCertTypes = [ CertificateType_RSA_Sign- , CertificateType_DSS_Sign- , CertificateType_ECDSA_Sign- ]- (certTypes, hashSigs)- | usedVersion < TLS12 = (defaultCertTypes, Nothing)- | otherwise =- let as = supportedHashSignatures $ ctxSupported ctx- in (nub $ mapMaybe hashSigToCertType as, Just as)- creq = CertRequest certTypes hashSigs- (map extractCAname $ serverCACertificates sparams)- usingHState ctx $ setCertReqSent True- sendPacket ctx (Handshake [creq])-- -- Send HelloDone- sendPacket ctx (Handshake [ServerHelloDone])-- setup_DHE = do- let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups- (dhparams, priv, pub) <-- case possibleFFGroups of- [] ->- let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams- in case findFiniteFieldGroup dhparams of- Just g -> do- usingHState ctx $ setNegotiatedGroup g- generateFFDHE ctx g- Nothing -> do- (priv, pub) <- generateDHE ctx dhparams- return (dhparams, priv, pub)- g:_ -> do- usingHState ctx $ setNegotiatedGroup g- generateFFDHE ctx g-- let serverParams = serverDHParamsFrom dhparams pub-- usingHState ctx $ setServerDHParams serverParams- usingHState ctx $ setDHPrivate priv- return serverParams-- -- Choosing a hash algorithm to sign (EC)DHE parameters- -- in ServerKeyExchange. Hash algorithm is not suggested by- -- the chosen cipher suite. So, it should be selected based on- -- the "signature_algorithms" extension in a client hello.- -- If RSA is also used for key exchange, this function is- -- not called.- decideHashSig pubKey = do- usedVersion <- usingState_ ctx getVersion- case usedVersion of- TLS12 -> do- let hashSigs = hashAndSignaturesInCommon ctx exts- case filter (pubKey `signatureCompatible`) hashSigs of- [] -> error ("no hash signature for " ++ pubkeyType pubKey)- x:_ -> return $ Just x- _ -> return Nothing-- generateSKX_DHE kxsAlg = do- serverParams <- setup_DHE- pubKey <- getLocalPublicKey ctx- mhashSig <- decideHashSig pubKey- signed <- digitallySignDHParams ctx serverParams pubKey mhashSig- case kxsAlg of- KX_RSA -> return $ SKX_DHE_RSA serverParams signed- KX_DSS -> return $ SKX_DHE_DSS serverParams signed- _ -> error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg)-- generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE-- setup_ECDHE grp = do- usingHState ctx $ setNegotiatedGroup grp- (srvpri, srvpub) <- generateECDHE ctx grp- let serverParams = ServerECDHParams grp srvpub- usingHState ctx $ setServerECDHParams serverParams- usingHState ctx $ setGroupPrivate srvpri- return serverParams-- generateSKX_ECDHE kxsAlg = do- let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups- grp <- case possibleECGroups of- [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure)- g:_ -> return g- serverParams <- setup_ECDHE grp- pubKey <- getLocalPublicKey ctx- mhashSig <- decideHashSig pubKey- signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig- case kxsAlg of- KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed- KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed- _ -> error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg)-- -- create a DigitallySigned objects for DHParams or ECDHParams.---- | receive Client data in handshake until the Finished handshake.------ <- [certificate]--- <- client key xchg--- <- [cert verify]--- <- change cipher--- <- finish----recvClientData :: ServerParams -> Context -> IO ()-recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)- where processClientCertificate (Certificates certs) = do- clientCertificate sparams ctx certs-- -- FIXME: We should check whether the certificate- -- matches our request and that we support- -- verifying with that certificate.-- return $ RecvStateHandshake processClientKeyExchange-- processClientCertificate p = processClientKeyExchange p-- -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,- -- so we must process any packet, and in case of handshake call processHandshake manually.- processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify- processClientKeyExchange p = unexpected (show p) (Just "client key exchange")-- -- Check whether the client correctly signed the handshake.- -- If not, ask the application on how to proceed.- --- processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do- processHandshake ctx hs-- certs <- checkValidClientCertChain ctx "change cipher message expected"-- usedVersion <- usingState_ ctx getVersion- -- Fetch all handshake messages up to now.- msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages-- pubKey <- usingHState ctx getRemotePublicKey- checkDigitalSignatureKey usedVersion pubKey-- verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig- clientCertVerify sparams ctx certs verif- return $ RecvStateNext expectChangeCipher-- processCertificateVerify p = do- chain <- usingHState ctx getClientCertChain- case chain of- Just cc | isNullCertificateChain cc -> return ()- | otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage)- Nothing -> return ()- expectChangeCipher p-- expectChangeCipher ChangeCipherSpec = do- return $ RecvStateHandshake expectFinish-- expectChangeCipher p = unexpected (show p) (Just "change cipher")-- expectFinish (Finished _) = return RecvStateDone- expectFinish p = unexpected (show p) (Just "Handshake Finished")--checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain-checkValidClientCertChain ctx errmsg = do- chain <- usingHState ctx getClientCertChain- let throwerror = Error_Protocol (errmsg , True, UnexpectedMessage)- case chain of- Nothing -> throwCore throwerror- Just cc | isNullCertificateChain cc -> throwCore throwerror- | otherwise -> return cc--hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]-hashAndSignaturesInCommon ctx exts =- let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of- -- See Section 7.4.1.4.1 of RFC 5246.- Nothing -> [(HashSHA1, SignatureECDSA)- ,(HashSHA1, SignatureRSA)- ,(HashSHA1, SignatureDSS)]- Just (SignatureAlgorithms sas) -> sas- sHashSigs = supportedHashSignatures $ ctxSupported ctx- -- 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'.- in sHashSigs `intersect` cHashSigs--negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]-negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of- Just (NegotiatedGroups clientGroups) ->- let serverGroups = supportedGroups (ctxSupported ctx)- in serverGroups `intersect` clientGroups- _ -> []--credentialDigitalSignatureKey :: Credential -> Maybe PubKey-credentialDigitalSignatureKey cred- | isDigitalSignaturePair keys = Just pubkey- | otherwise = Nothing- where keys@(pubkey, _) = credentialPublicPrivateKeys cred--filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials-filterCredentials p (Credentials l) = Credentials (filter p l)--filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials-filterSortCredentials rankFun (Credentials creds) =- let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ]- in Credentials [ cred | (Just _, cred) <- orderedPairs ]--isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool-isCredentialAllowed ver exts 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 extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of- Nothing -> const True- Just (NegotiatedGroups sg) -> (`elem` sg)- | otherwise = const True---- Filters a list of candidate credentials with credentialMatchesHashSignatures.------ Algorithms to filter with are taken from "signature_algorithms_cert"--- extension when it exists, else from "signature_algorithms" when clients do--- not implement the new extension (see RFC 8446 section 4.2.3).------ Resulting credential list can be used as input to the hybrid cipher-and---- certificate selection for TLS12, or to the direct certificate selection--- simplified with TLS13. As filtering credential signatures with client---- advertised algorithms is not supposed to cause negotiation failure, in case--- of dead end with the subsequent selection process, this process should always--- be restarted with the unfiltered credential list as input (see fallback--- certificate chains, described in same RFC section).------ Calling code should not forget to apply constraints of extension--- "signature_algorithms" to any signature-based key exchange derived from the--- output credentials. Respecting client constraints on KX signatures is--- mandatory but not implemented by this function.-filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials-filterCredentialsWithHashSignatures exts =- case withExt extensionID_SignatureAlgorithmsCert of- Just (SignatureAlgorithmsCert sas) -> withAlgs sas- Nothing ->- case withExt extensionID_SignatureAlgorithms of- Nothing -> id- Just (SignatureAlgorithms sas) -> withAlgs sas- where- withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello- withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas)---- returns True if certificate filtering with "signature_algorithms_cert" /--- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so--- handshake with lower security)-cipherListCredentialFallback :: [Cipher] -> Bool-cipherListCredentialFallback = all nonDH- where- nonDH x = case cipherKeyExchange x of- CipherKeyExchange_DHE_RSA -> False- CipherKeyExchange_DHE_DSS -> False- CipherKeyExchange_ECDHE_RSA -> False- CipherKeyExchange_ECDHE_ECDSA -> False- CipherKeyExchange_TLS13 -> False- _ -> True--storePrivInfoServer :: MonadIO m => Context -> Credential -> m ()-storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey)---- TLS 1.3 or later-handshakeServerWithTLS13 :: ServerParams- -> Context- -> Version- -> [ExtensionRaw]- -> [CipherID]- -> Maybe String- -> Session- -> IO ()-handshakeServerWithTLS13 sparams ctx chosenVersion exts clientCiphers _serverName clientSession = do- when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $- throwCore $ Error_Protocol ("extension pre_shared_key must be last", True, IllegalParameter)- -- Deciding cipher.- -- 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) $ throwCore $- Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)- let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion- usedHash = cipherHash usedCipher- rtt0 = case extensionLookup extensionID_EarlyData exts >>= 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 extensionID_KeyShare exts of- Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, MissingExtension)- Just kss -> case extensionDecode MsgTClientHello kss of- Just (KeyShareClientHello kses) -> return kses- Just _ -> error "handshakeServerWithTLS13: invalid KeyShare value"- _ -> throwCore $ Error_Protocol ("broken key_share", True, DecodeError)- mshare <- findKeyShare keyShares serverGroups- case mshare of- Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession- Just keyShare -> doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash keyShare clientSession rtt0- where- ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers- serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams)- serverGroups = supportedGroups (ctxSupported ctx)--findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)-findKeyShare ks ggs = go ggs- where- go [] = return Nothing- go (g:gs) = case filter (grpEq g) ks of- [] -> go gs- [k] -> do- unless (checkKeyShareKeyLength k) $- throwCore $ Error_Protocol ("broken key_share", True, IllegalParameter)- return $ Just k- _ -> throwCore $ Error_Protocol ("duplicated key_share", True, IllegalParameter)- grpEq g ent = g == keyShareEntryGroup ent--doHandshake13 :: ServerParams -> Context -> Version- -> Cipher -> [ExtensionRaw]- -> Hash -> KeyShareEntry- -> Session -> Bool- -> IO ()-doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do- newSession ctx >>= \ss -> usingState_ ctx $ do- setSession ss False- setClientSupportsPHA supportsPHA- usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare- srand <- setServerParameter- -- ALPN is used in choosePSK- protoExt <- applicationProtocol ctx exts sparams- (psk, binderInfo, is0RTTvalid) <- choosePSK- earlyKey <- calculateEarlySecret ctx choice (Left psk) True- let earlySecret = pairBase earlyKey- clientEarlySecret = pairClient earlyKey- extensions <- checkBinder earlySecret binderInfo- hrr <- usingState_ ctx getTLS13HRR- let authenticated = isJust binderInfo- rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid- extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)- let allCreds = filterCredentials (isCredentialAllowed chosenVersion exts) $- extraCreds `mappend` sharedCredentials (ctxShared ctx)- ----------------------------------------------------------------- established <- ctxEstablished ctx- if established /= NotEstablished then- if rtt0OK then do- usingHState ctx $ setTLS13HandshakeMode RTT0- usingHState ctx $ setTLS13RTT0Status RTT0Accepted- else do- usingHState ctx $ setTLS13HandshakeMode RTT0- usingHState ctx $ setTLS13RTT0Status RTT0Rejected- else- if authenticated then- usingHState ctx $ setTLS13HandshakeMode PreSharedKey- else- -- FullHandshake or HelloRetryRequest- return ()- mCredInfo <- if authenticated then return Nothing else decideCredentialInfo allCreds- (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare- ensureRecvComplete ctx- (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do- sendServerHello keyShare srand extensions- sendChangeCipherSpec13 ctx- ----------------------------------------------------------------- handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe- let serverHandshakeSecret = triServer handKey- clientHandshakeSecret = triClient handKey- handSecret = triBase handKey- liftIO $ do- if rtt0OK && not (ctxQUICMode ctx)- then setRxState ctx usedHash usedCipher clientEarlySecret- else setRxState ctx usedHash usedCipher clientHandshakeSecret- setTxState ctx usedHash usedCipher serverHandshakeSecret- let mEarlySecInfo- | rtt0OK = Just $ EarlySecretInfo usedCipher clientEarlySecret- | otherwise = Nothing- handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret)- contextSync ctx $ SendServerHello exts mEarlySecInfo handSecInfo- ----------------------------------------------------------------- sendExtensions rtt0OK protoExt- case mCredInfo of- Nothing -> return ()- Just (cred, hashSig) -> sendCertAndVerify cred hashSig- let ServerTrafficSecret shs = serverHandshakeSecret- rawFinished <- makeFinished ctx usedHash shs- loadPacket13 ctx $ Handshake13 [rawFinished]- return (clientHandshakeSecret, handSecret)- sfSentTime <- getCurrentTimeFromBase- ----------------------------------------------------------------- hChSf <- transcriptHash ctx- appKey <- calculateApplicationSecret ctx choice handSecret hChSf- let clientApplicationSecret0 = triClient appKey- serverApplicationSecret0 = triServer appKey- applicationSecret = triBase appKey- setTxState ctx usedHash usedCipher serverApplicationSecret0- 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-- let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do- let ClientTrafficSecret chs = clientHandshakeSecret- checkFinished ctx usedHash chs hChBeforeCf verifyData- handshakeTerminate13 ctx- setRxState ctx usedHash usedCipher clientApplicationSecret0- sendNewSessionTicket applicationSecret sfSentTime- expectFinished _ hs = unexpected (show hs) (Just "finished 13")-- let expectEndOfEarlyData EndOfEarlyData13 =- setRxState ctx usedHash usedCipher clientHandshakeSecret- expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data")-- if not authenticated && serverWantClientCert sparams then- runRecvHandshake13 $ do- skip <- recvHandshake13 ctx expectCertificate- unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx)- recvHandshake13hash ctx expectFinished- ensureRecvComplete ctx- else if rtt0OK && not (ctxQUICMode ctx) then- setPendingActions ctx [PendingAction True expectEndOfEarlyData- ,PendingActionHash True expectFinished]- else- runRecvHandshake13 $ do- recvHandshake13hash ctx expectFinished- ensureRecvComplete ctx- where- choice = makeCipherChoice chosenVersion usedCipher-- setServerParameter = do- srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams- usingState_ ctx $ setVersion chosenVersion- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- return srand-- supportsPHA = case extensionLookup extensionID_PostHandshakeAuth exts >>= extensionDecode MsgTClientHello of- Just PostHandshakeAuth -> True- Nothing -> False-- choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of- Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> do- when (null dhModes) $- throwCore $ Error_Protocol ("no psk_key_exchange_modes extension", True, 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 Just tinfo = 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)-- 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 = chosenVersion == sessionVersion sdata- isSameALPN = sessionALPN sdata == malpn- isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required- is0RTTvalid = isSameVersion && isSameCipher && isSameALPN- return (isPSKvalid, is0RTTvalid)-- 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 `bytesEq` binder') $- decryptError "PSK binder validation failed"- let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n- return [ExtensionRaw extensionID_PreSharedKey selectedIdentity]-- decideCredentialInfo allCreds = do- cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts of- Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension)- Just sa -> case extensionDecode MsgTClientHello sa of- Nothing -> throwCore $ Error_Protocol ("broken signature_algorithms extension", True, DecodeError)- Just (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- -- RFC 8446 section 4.4.2.2).- let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx- hashSigs = sHashSigs `intersect` cHashSigs- cltCreds = filterCredentialsWithHashSignatures exts allCreds- case credentialsFindForSigning13 hashSigs cltCreds of- Nothing ->- case credentialsFindForSigning13 hashSigs allCreds of- Nothing -> throwCore $ Error_Protocol ("credential not found", True, HandshakeFailure)- mcs -> return mcs- mcs -> return mcs-- sendServerHello keyShare srand extensions = do- let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare- selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion- extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare- : ExtensionRaw extensionID_SupportedVersions selectedVersion- : extensions- helo = ServerHello13 srand clientSession (cipherID usedCipher) extensions'- loadPacket13 ctx $ Handshake13 [helo]-- sendCertAndVerify cred@(certChain, _) hashSig = 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]- usingHState ctx $ setCertReqSent True-- let CertificateChain cs = certChain- ess = replicate (length cs) []- loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess]- hChSc <- transcriptHash ctx- pubkey <- getLocalPublicKey ctx- vrfy <- makeCertVerify ctx pubkey hashSig hChSc- loadPacket13 ctx $ Handshake13 [vrfy]-- sendExtensions rtt0OK protoExt = do- msni <- liftIO $ usingState_ ctx getClientSNI- let sniExtension = 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 extensionID_ServerName ""- Nothing -> Nothing- mgroup <- usingHState ctx getNegotiatedGroup- let serverGroups = supportedGroups (ctxSupported ctx)- groupExtension- | null serverGroups = Nothing- | maybe True (== head serverGroups) mgroup = Nothing- | otherwise = Just $ ExtensionRaw extensionID_NegotiatedGroups $ extensionEncode (NegotiatedGroups serverGroups)- let earlyDataExtension- | rtt0OK = Just $ ExtensionRaw extensionID_EarlyData $ extensionEncode (EarlyDataIndication Nothing)- | otherwise = Nothing- let extensions = sharedHelloExtensions (serverShared sparams)- ++ catMaybes [earlyDataExtension- ,groupExtension- ,sniExtension- ]- ++ protoExt- extensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions- loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions']-- sendNewSessionTicket applicationSecret sfSentTime = when sendNST $ do- cfRecvTime <- getCurrentTimeFromBase- let rtt = cfRecvTime - sfSentTime- nonce <- getStateRNG ctx 32- resumptionMasterSecret <- calculateResumptionSecret ctx choice applicationSecret- let life = toSeconds $ serverTicketLifetime sparams- psk = derivePSK choice resumptionMasterSecret nonce- (label, add) <- generateSession life psk rtt0max rtt- let nst = createNewSessionTicket life add nonce label rtt0max- sendPacket13 ctx $ Handshake13 [nst]- where- sendNST = PSK_DHE_KE `elem` dhModes- generateSession life psk maxSize rtt = do- Session (Just sessionId) <- newSession ctx- tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt)- sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk- let mgr = sharedSessionManager $ serverShared sparams- sessionEstablish mgr sessionId sdata- return (sessionId, ageAdd tinfo)- createNewSessionTicket life add nonce label maxSize =- NewSessionTicket13 life add nonce label extensions- where- tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize- extensions = [ExtensionRaw extensionID_EarlyData tedi]- toSeconds i | i < 0 = 0- | i > 604800 = 604800- | otherwise = fromIntegral i-- dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of- Just (PskKeyExchangeModes ms) -> ms- Nothing -> []-- expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool- expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do- when (certCtx /= "") $ throwCore $ Error_Protocol ("certificate request context MUST be empty", True, IllegalParameter)- -- fixme checking _ext- clientCertificate sparams ctx certs- return $ isNullCertificateChain certs- expectCertificate hs = unexpected (show hs) (Just "certificate 13")-- hashSize = hashDigestSize usedHash- zero = B.replicate hashSize 0--expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()-expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do- certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected"- pubkey <- case cc of- [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure)- c:_ -> return $ certPubKey $ getCertificate c- ver <- usingState_ ctx getVersion- checkDigitalSignatureKey ver pubkey- usingHState ctx $ setPublicKey pubkey- verif <- checkCertVerify ctx pubkey sigAlg sig hChCc- clientCertVerify sparams ctx certs verif-expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13")--helloRetryRequest :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> IO ()-helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = do- twice <- usingState_ ctx getTLS13HRR- when twice $- throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure)- usingState_ ctx $ setTLS13HRR True- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of- Just (NegotiatedGroups gs) -> gs- Nothing -> []- possibleGroups = serverGroups `intersect` clientGroups- case possibleGroups of- [] -> throwCore $ Error_Protocol ("no group in common with the client for HRR", True, HandshakeFailure)- g:_ -> do- let serverKeyShare = extensionEncode $ KeyShareHRR g- selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion- extensions = [ExtensionRaw extensionID_KeyShare serverKeyShare- ,ExtensionRaw extensionID_SupportedVersions selectedVersion]- hrr = ServerHello13 hrrRandom clientSession (cipherID usedCipher) extensions- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- runPacketFlight ctx $ do- loadPacket13 ctx $ Handshake13 [hrr]- sendChangeCipherSpec13 ctx- handshakeServer sparams ctx--findHighestVersionFrom :: Version -> [Version] -> Maybe Version-findHighestVersionFrom clientVersion allowedVersions =- case filter (clientVersion >=) $ sortOn Down allowedVersions of- [] -> Nothing- v:_ -> Just v---- We filter our allowed ciphers here according to dynamic credential lists.--- Credentials 'creds' come from server parameters but also SNI callback.--- When the key exchange requires a signature, we use a--- 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)- where authorizedCKE cipher =- case cipherKeyExchange cipher of- CipherKeyExchange_RSA -> canEncryptRSA- CipherKeyExchange_DH_Anon -> True- CipherKeyExchange_DHE_RSA -> canSignRSA- CipherKeyExchange_DHE_DSS -> canSignDSS- CipherKeyExchange_ECDHE_RSA -> canSignRSA- CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA- -- unimplemented: non ephemeral DH & ECDH.- -- Note, these *should not* be implemented, and have- -- (for example) been removed in OpenSSL 1.1.0- --- CipherKeyExchange_DH_DSS -> False- CipherKeyExchange_DH_RSA -> False- CipherKeyExchange_ECDH_ECDSA -> False- CipherKeyExchange_ECDH_RSA -> False- CipherKeyExchange_TLS13 -> False -- not reached-- canSignDSS = KX_DSS `elem` signingAlgs- canSignRSA = KX_RSA `elem` signingAlgs- canSignECDSA = KX_ECDSA `elem` signingAlgs- canEncryptRSA = isJust $ credentialsFindForDecrypting creds- signingAlgs = credentialsListSigningAlgorithms sigCreds--findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version-findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of- [] -> Nothing- v:_ -> Just v- where- svs = sortOn Down serverVersions- cvs = sortOn Down $ filter (> SSL3) clientVersions--applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]-applicationProtocol ctx exts sparams = do- -- ALPN (Application Layer Protocol Negotiation)- case extensionLookup extensionID_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", True, NoApplicationProtocol)- usingState_ ctx $ do- setExtensionALPN True- setNegotiatedProtocol proto- return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation- (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]- _ -> return []--credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)-credentialsFindForSigning13 hss0 creds = loop hss0- where- loop [] = Nothing- loop (hs:hss) = case credentialsFindForSigning13' hs creds of- Nothing -> loop hss- Just cred -> Just (cred, hs)---- See credentialsFindForSigning.-credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential-credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l- where- forSigning cred = case credentialDigitalSignatureKey cred of- Nothing -> False- Just pub -> pub `signatureCompatible13` sigAlg--clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()-clientCertificate sparams ctx certs = do- -- run certificate recv hook- ctxWithHooks ctx (`hookRecvCertificates` certs)- -- Call application callback to see whether the- -- certificate chain is acceptable.- --- usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException- case usage of- CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs- CertificateUsageReject reason -> certificateRejected reason-- -- Remember cert chain for later use.- --- usingHState ctx $ setClientCertChain certs--clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()-clientCertVerify sparams ctx certs verif = do- if verif then do- -- When verification succeeds, commit the- -- client certificate chain to the context.- --- usingState_ ctx $ setClientCertificateChain certs- return ()- else do- -- Either verification failed because of an- -- invalid format (with an error message), or- -- the signature is wrong. In either case,- -- ask the application if it wants to- -- proceed, we will do that.- res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)- if res then do- -- When verification fails, but the- -- application callbacks accepts, we- -- also commit the client certificate- -- chain to the context.- usingState_ ctx $ setClientCertificateChain certs- else decryptError "verification failed"--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--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", True, DecodeError)- let certReq = fromJust "certReq" mCertReq-- -- fixme checking _ext- clientCertificate sparams ctx certs-- baseHState <- saveHState ctx- processHandshake13 ctx certReq- processHandshake13 ctx h-- (usedHash, _, level, applicationSecretN) <- getRxState ctx- unless (level == CryptApplicationSecret) $- throwCore $ Error_Protocol ("tried post-handshake authentication without application traffic secret", True, InternalError)-- let expectFinished hChBeforeCf (Finished13 verifyData) = do- checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData- void $ restoreHState ctx baseHState- expectFinished _ hs = unexpected (show hs) (Just "finished 13")-- -- 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 setPendingActions ctx [ PendingActionHash False expectFinished ]- else setPendingActions ctx [ PendingActionHash False (expectCertVerify sparams ctx)- , PendingActionHash False expectFinished- ]--postHandshakeAuthServerWith _ _ _ =- throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthServerWith", True, UnexpectedMessage)--contextSync :: Context -> ServerState -> IO ()-contextSync ctx ctl = case ctxHandshakeSync ctx of- HandshakeSync _ sync -> sync ctx ctl++module Network.TLS.Handshake.Server (+ handshakeServer,+ handshakeServerWith,+ requestCertificateServer,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..),+) where++import Control.Monad.State.Strict+import Data.Maybe++import Network.TLS.Context.Internal+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Server.ClientHello+import Network.TLS.Handshake.Server.ClientHello12+import Network.TLS.Handshake.Server.ClientHello13+import Network.TLS.Handshake.Server.ServerHello12+import Network.TLS.Handshake.Server.ServerHello13+import Network.TLS.Handshake.Server.TLS12+import Network.TLS.Handshake.Server.TLS13+import Network.TLS.Imports+import Network.TLS.Struct++-- Put the server context in handshake mode.+--+-- Expect to receive as first packet a client hello handshake message+--+-- This is just a helper to pop the next message from the recv layer,+-- and call handshakeServerWith.+handshakeServer :: ServerParams -> Context -> IO ()+handshakeServer sparams ctx = liftIO $ do+ hbs <- recvPacketHandshake ctx+ case hbs of+ chb : _ -> handshake sparams ctx chb+ _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello")++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 popped from the recv layer to inspect the packet.+--+-- When the function returns, a new handshake has been successfully negotiated.+-- On any error, a HandshakeFailed exception is raised.+handshake :: ServerParams -> Context -> HandshakeR -> IO ()+handshake sparams ctx chb@(ClientHello ch, bs) = do+ (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs+ if chosenVersion == TLS13+ then do+ -- fixme: we should check if the client random is the same as+ -- that in the first client hello in the case of hello retry.+ -- r0 :: Cipher, Hash, Bool+ (keyShareResult, r0, r1) <-+ processClientHello13 sparams ctx chI+ 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+ SelectKeyShareFound cliKeyShare -> do+ unless (checkClientKeyShareKeyLength cliKeyShare) $+ throwCore $+ Error_Protocol "broken key_share" IllegalParameter+ -- r2 :: ( SecretTriple ApplicationSecret+ -- , ClientTrafficSecret HandshakeSecret+ -- , Bool -- authenticated+ -- , Bool) -- rtt0OK+ r2 <-+ sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd+ recvClientSecondFlight13 sparams ctx r2 chI+ else do+ r <-+ processClientHello12 sparams ctx chI+ updateTranscriptHash12 ctx chb+ resumeSessionData <-+ sendServerHello12 sparams ctx r chI+ recvClientSecondFlight12 sparams ctx resumeSessionData+handshake _ _ _ = throwCore $ Error_Protocol "client Hello is expected" HandshakeFailure
+ Network/TLS/Handshake/Server/ClientHello.hs view
@@ -0,0 +1,305 @@+{-# 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.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+ -> 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+ ver <- usingState_ ctx (getVersionWithDefault TLS12)+ when (ver == TLS13) $+ throwCore $+ Error_Protocol "renegotiation is not allowed in TLS 1.3" UnexpectedMessage+ -- rejecting client initiated renegotiation to prevent DOS.+ eof <- ctxEOF ctx+ let renegotiation = established == Established && not eof+ when+ (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx))+ $ throwCore+ $ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation+ -- check if policy allow this new handshake to happens+ handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)+ unless+ handshakeAuthorized+ (throwCore $ Error_HandshakePolicy "server: handshake denied")+ updateMeasure ctx incrementNbHandshakes++ when (chVersion /= TLS12) $+ throwCore $+ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion++ -- Fallback SCSV: RFC7507+ -- TLS_FALLBACK_SCSV: {0x56, 0x00}+ when+ ( supportedFallbackScsv (ctxSupported ctx)+ && (CipherId 0x5600 `elem` chCiphers)+ && chVersion < TLS12+ )+ $ throwCore+ $ Error_Protocol "fallback is not allowed" InappropriateFallback++ -- choosing TLS version+ 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+ mVersion = debugVersionForced $ serverDebug sparams+ chosenVersion <- case mVersion of+ Just cver -> return cver+ Nothing ->+ if (TLS13 `elem` serverVersions) && clientVersions /= []+ then case findHighestVersionFrom13 clientVersions serverVersions of+ Nothing ->+ throwCore $+ Error_Protocol+ ("client versions " ++ show clientVersions ++ " is not supported")+ ProtocolVersion+ Just v -> return v+ else case findHighestVersionFrom clientVersion serverVersions of+ Nothing ->+ throwCore $+ Error_Protocol+ ("client version " ++ show clientVersion ++ " is not supported")+ ProtocolVersion+ Just v -> return v++ -- 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++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) = listToMaybe (mapMaybe toHostName ns)+ toHostName (ServerNameHostName hostName) = Just hostName+ toHostName (ServerNameOther _) = Nothing++findHighestVersionFrom :: Version -> [Version] -> Maybe Version+findHighestVersionFrom clientVersion allowedVersions =+ case filter (clientVersion >=) $ sortOn Down allowedVersions of+ [] -> Nothing+ v : _ -> Just v++findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version+findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of+ [] -> Nothing+ v : _ -> Just v+ 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
@@ -0,0 +1,235 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Server.ClientHello12 (+ processClientHello12,+) where++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Credentials+import Network.TLS.Crypto+import Network.TLS.ErrT+import Network.TLS.Extension+import Network.TLS.Handshake.Server.Common+import Network.TLS.Handshake.Signature+import Network.TLS.Imports+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Types (CipherId (..), Role (..))++----------------------------------------------------------------++-- serverSupported sparams == ctxSupported ctx++-- TLS 1.2 or earlier+processClientHello12+ :: ServerParams+ -> Context+ -> ClientHello+ -> IO (Cipher, Maybe Credential)+processClientHello12 sparams ctx ch = do+ let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams+ when secureRenegotiation $ checkSecureRenegotiation ctx ch+ serverName <- usingState_ ctx getClientSNI+ let hooks = serverHooks sparams+ extraCreds <- onServerNameIndication hooks serverName+ let (creds, signatureCreds, ciphersFilteredVersion) =+ 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) $+ throwCore $+ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure+ let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion+ mcred <- chooseCreds usedCipher creds signatureCreds+ return (usedCipher, mcred)++checkSecureRenegotiation :: Context -> ClientHello -> IO ()+checkSecureRenegotiation ctx CH{..} = do+ -- RFC 5746: secure renegotiation+ -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}+ when (CipherId 0xff `elem` chCiphers) $+ usingState_ ctx $+ setSecureRenegotiation True+ case extensionLookup EID_SecureRenegotiation chExtensions of+ Just content -> usingState_ ctx $ do+ VerifyData cvd <- getVerifyData ClientRole+ let bs = extensionEncode (SecureRenegotiation cvd "")+ unless (bs == content) $+ throwError $+ Error_Protocol+ ("client verified data not matching: " ++ show cvd ++ ":" ++ show content)+ HandshakeFailure++ setSecureRenegotiation True+ _ -> return ()++----------------------------------------------------------------++credsTriple+ :: ServerParams+ -> ClientHello+ -> Credentials+ -> (Credentials, Credentials, [Cipher])+credsTriple sparams CH{..} extraCreds+ | cipherListCredentialFallback cltCiphers = (allCreds, sigAllCreds, allCiphers)+ | otherwise = (cltCreds, sigCltCreds, cltCiphers)+ where+ ciphers = supportedCiphers $ serverSupported sparams++ commonCiphers creds sigCreds = intersectCiphers chCiphers availableCiphers+ where+ availableCiphers = getCiphers ciphers creds sigCreds++ p = makeCredentialPredicate TLS12 chExtensions+ allCreds =+ 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+ -- will be met.++ -- Some ciphers require a signature and a hash. With TLS 1.2 the hash+ -- algorithm is selected from a combination of server configuration and+ -- the client "supported_signatures" extension. So we cannot pick+ -- such a cipher if no hash is available for it. It's best to skip this+ -- cipher and pick another one (with another key exchange).++ -- 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 evaluated from+ -- the resulting credentials.++ supported = serverSupported sparams+ groups = supportedGroups supported+ possibleGroups = negotiatedGroupsInCommon groups chExtensions+ possibleECGroups = possibleGroups `intersect` availableECGroups+ possibleFFGroups = possibleGroups `intersect` availableFFGroups+ hasCommonGroupForECDHE = not (null possibleECGroups)+ hasCommonGroupForFFDHE = not (null possibleFFGroups)+ hasCustomGroupForFFDHE = isJust (serverDHEParams sparams)+ canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE+ hasCommonGroup cipher =+ case cipherKeyExchange cipher of+ CipherKeyExchange_DH_Anon -> canFFDHE+ CipherKeyExchange_DHE_RSA -> canFFDHE+ CipherKeyExchange_DHE_DSA -> canFFDHE+ CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE+ CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE+ _ -> True -- group not used++ -- Ciphers are selected according to TLS version, availability of+ -- (EC)DHE group and credential depending on key exchange.+ cipherAllowed cipher = cipherAllowedForVersion TLS12 cipher && hasCommonGroup cipher+ selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials)++ -- Build a list of all hash/signature algorithms in common between+ -- client and server.+ 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+ -- in order to sort credentials according to server hash/signature+ -- preference. When the certificate has no matching hash/signature in+ -- 'possibleHashSigAlgs' the result is Nothing, and the credential will+ -- not be used to sign. This avoids a failure later in 'decideHashSig'.+ signingRank cred =+ case credentialDigitalSignatureKey cred of+ Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs+ Nothing -> Nothing++ -- Finally compute credential lists and resulting cipher list.+ --+ -- 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 RFC 8446 section 4.4.2.2).+ -- The condition is based on resulting (EC)DHE ciphers so that+ -- filtering credentials does not give advantage to a less secure+ -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon.+ cltCreds = filterCredentialsWithHashSignatures chExtensions allCreds+ sigCltCreds = filterSortCredentials signingRank cltCreds+ sigAllCreds = filterSortCredentials signingRank allCreds+ cltCiphers = selectCipher cltCreds sigCltCreds+ allCiphers = selectCipher allCreds sigAllCreds++chooseCreds :: Cipher -> Credentials -> Credentials -> IO (Maybe Credential)+chooseCreds usedCipher creds signatureCreds = case cipherKeyExchange usedCipher of+ CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds+ CipherKeyExchange_DH_Anon -> return Nothing+ CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds+ CipherKeyExchange_DHE_DSA -> return $ credentialsFindForSigning KX_DSA signatureCreds+ CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds+ CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds+ _ ->+ throwCore $+ Error_Protocol "key exchange algorithm not implemented" HandshakeFailure++----------------------------------------------------------------++negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]+negotiatedGroupsInCommon serverGroups exts =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ exts+ []+ (\(SupportedGroups clientGroups) -> serverGroups `intersect` clientGroups)++----------------------------------------------------------------++filterSortCredentials+ :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials+filterSortCredentials rankFun (Credentials creds) =+ let orderedPairs = sortOn fst [(rankFun cred, cred) | cred <- creds]+ in Credentials [cred | (Just _, cred) <- orderedPairs]++-- returns True if certificate filtering with "signature_algorithms_cert" /+-- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so+-- handshake with lower security)+cipherListCredentialFallback :: [Cipher] -> Bool+cipherListCredentialFallback = all nonDH+ where+ nonDH x = case cipherKeyExchange x of+ CipherKeyExchange_DHE_RSA -> False+ CipherKeyExchange_DHE_DSA -> False+ CipherKeyExchange_ECDHE_RSA -> False+ CipherKeyExchange_ECDHE_ECDSA -> False+ CipherKeyExchange_TLS13 -> False+ _ -> True++-- We filter our allowed ciphers here according to dynamic credential lists.+-- Credentials 'creds' come from server parameters but also SNI callback.+-- When the key exchange requires a signature, we use a+-- 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 :: [Cipher] -> Credentials -> Credentials -> [Cipher]+getCiphers ciphers creds sigCreds = filter authorizedCKE ciphers+ where+ authorizedCKE cipher =+ case cipherKeyExchange cipher of+ CipherKeyExchange_RSA -> canEncryptRSA+ CipherKeyExchange_DH_Anon -> True+ CipherKeyExchange_DHE_RSA -> canSignRSA+ CipherKeyExchange_DHE_DSA -> canSignDSA+ CipherKeyExchange_ECDHE_RSA -> canSignRSA+ CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA+ -- unimplemented: non ephemeral DH & ECDH.+ -- Note, these *should not* be implemented, and have+ -- (for example) been removed in OpenSSL 1.1.0+ --+ CipherKeyExchange_DH_DSA -> False+ CipherKeyExchange_DH_RSA -> False+ CipherKeyExchange_ECDH_ECDSA -> False+ CipherKeyExchange_ECDH_RSA -> False+ CipherKeyExchange_TLS13 -> False -- not reached+ canSignDSA = KX_DSA `elem` signingAlgs+ canSignRSA = KX_RSA `elem` signingAlgs+ canSignECDSA = KX_ECDSA `elem` signingAlgs+ canEncryptRSA = isJust $ credentialsFindForDecrypting creds+ signingAlgs = credentialsListSigningAlgorithms sigCreds
+ Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Server.ClientHello13 (+ processClientHello13,+ 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.Common13+import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.State+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.Types++limitSupportedGroups :: Int+limitSupportedGroups = 64++-- TLS 1.3 or later+processClientHello13+ :: ServerParams+ -> Context+ -> ClientHello+ -> IO+ ( SelectKeyShareResult+ , (Cipher, Hash, Bool) -- rtt0+ , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ )+processClientHello13 sparams ctx ch@CH{..} = do+ when+ (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions)+ $ throwCore+ $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter+ -- Deciding cipher.+ -- 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) $+ 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 =+ 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+ 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 = intersectCiphers chCiphers serverCiphers+ serverCiphers =+ filter+ (cipherAllowedForVersion TLS13)+ (supportedCiphers $ serverSupported sparams)+ serverGroups = supportedGroupsTLS13 $ serverSupported sparams++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) -- authenticated, is0RTTvalid+pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do+ (psk, binderInfo, is0RTTvalid) <- choosePSK+ earlyKey <- calculateEarlySecret ctx choice (Left psk)+ let earlySecret = pairBase earlyKey+ authenticated = isJust binderInfo+ preSharedKeyExt <- checkBinder earlySecret binderInfo+ return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid)+ where+ choice = makeCipherChoice TLS13 usedCipher++ choosePSK =+ lookupAndDecodeAndDo+ EID_PreSharedKey+ MsgTClientHello+ chExtensions+ (return (zero, Nothing, False))+ selectPSK++ selectPSK (PreSharedKeyClientHello (PskIdentity identity 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+ -- sessionInvalidate is not used for TLS 1.3+ -- because PSK is always changed.+ -- So, identity is not stored in Context.+ msdata <-+ if rtt0+ then sessionResumeOnlyOnce mgr identity+ else sessionResume mgr identity+ case msdata of+ Just sdata -> do+ let tinfo = fromJust $ sessionTicketInfo sdata+ psk = sessionSecret sdata+ isFresh <- checkFreshness tinfo obfAge+ (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata+ if isPSKvalid && isFresh+ then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)+ else -- fall back to full handshake+ return (zero, Nothing, False)+ _ -> return (zero, Nothing, False)+ else return (zero, Nothing, False)+ selectPSK _ = return (zero, Nothing, False)++ 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+ -- ALPN should be checked.+ -- But it's an extension in EE, sigh.+ -- malpn <- usingState_ ctx getNegotiatedProtocol+ let isSameSNI = sessionClientSNI sdata == msni+ isSameCipher = sessionCipher sdata == cipherID usedCipher+ ciphers = supportedCiphers $ serverSupported sparams+ scid = sessionCipher sdata+ isSameKDF = case findCipher scid 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)++ dhModes =+ lookupAndDecode+ EID_PskKeyExchangeModes+ MsgTClientHello+ chExtensions+ []+ (\(PskKeyExchangeModes ms) -> ms)++ hashSize = hashDigestSize usedHash+ zero = B.replicate hashSize 0
+ Network/TLS/Handshake/Server/Common.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.Server.Common (+ applicationProtocol,+ checkValidClientCertChain,+ clientCertificate,+ credentialDigitalSignatureKey,+ filterCredentials,+ filterCredentialsWithHashSignatures,+ makeCredentialPredicate,+ isCredentialAllowed,+ storePrivInfoServer,+ hashAndSignaturesInCommon,+ processRecordSizeLimit,+) where++import Control.Monad.State.Strict+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..))++import Network.TLS.Context.Internal+import Network.TLS.Credentials+import Network.TLS.Crypto+import Network.TLS.Extension+import Network.TLS.Handshake.Certificate+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Util (catchException)+import Network.TLS.X509++checkValidClientCertChain+ :: MonadIO m => Context -> String -> m CertificateChain+checkValidClientCertChain ctx errmsg = do+ chain <- usingHState ctx getClientCertChain+ let throwerror = Error_Protocol errmsg UnexpectedMessage+ case chain of+ Nothing -> throwCore throwerror+ Just cc+ | isNullCertificateChain cc -> throwCore throwerror+ | otherwise -> return cc++credentialDigitalSignatureKey :: Credential -> Maybe PubKey+credentialDigitalSignatureKey cred+ | isDigitalSignaturePair keys = Just pubkey+ | otherwise = Nothing+ where+ keys@(pubkey, _) = credentialPublicPrivateKeys cred++filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials+filterCredentials p (Credentials l) = Credentials (filter p l)++-- 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++-- Filters a list of candidate credentials with credentialMatchesHashSignatures.+--+-- Algorithms to filter with are taken from "signature_algorithms_cert"+-- extension when it exists, else from "signature_algorithms" when clients do+-- not implement the new extension (see RFC 8446 section 4.2.3).+--+-- Resulting credential list can be used as input to the hybrid cipher-and-+-- certificate selection for TLS12, or to the direct certificate selection+-- simplified with TLS13. As filtering credential signatures with client-+-- advertised algorithms is not supposed to cause negotiation failure, in case+-- of dead end with the subsequent selection process, this process should always+-- be restarted with the unfiltered credential list as input (see fallback+-- certificate chains, described in same RFC section).+--+-- Calling code should not forget to apply constraints of extension+-- "signature_algorithms" to any signature-based key exchange derived from the+-- output credentials. Respecting client constraints on KX signatures is+-- mandatory but not implemented by this function.+filterCredentialsWithHashSignatures+ :: [ExtensionRaw] -> Credentials -> Credentials+filterCredentialsWithHashSignatures exts =+ lookupAndDecode+ EID_SignatureAlgorithmsCert+ MsgTClientHello+ exts+ lookupSignatureAlgorithms+ (\(SignatureAlgorithmsCert sas) -> withAlgs sas)+ where+ 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 (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+ 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+ -- run certificate recv hook+ ctxWithHooks ctx (`hookRecvCertificates` certs)+ -- Call application callback to see whether the+ -- certificate chain is acceptable.+ --+ usage <-+ liftIO $+ catchException+ (onClientCertificate (serverHooks sparams) certs)+ rejectOnException+ case usage of+ 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
@@ -0,0 +1,325 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Server.ServerHello12 (+ sendServerHello12,+) where++import Data.ByteArray (convert)++import Network.TLS.Cipher+import Network.TLS.Compression+import Network.TLS.Context.Internal+import Network.TLS.Credentials+import Network.TLS.Crypto+import Network.TLS.Extension+import Network.TLS.Handshake.Certificate+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Random+import Network.TLS.Handshake.Server.Common+import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.State+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.Types+import Network.TLS.X509 hiding (Certificate)++sendServerHello12+ :: ServerParams+ -> Context+ -> (Cipher, Maybe Credential)+ -> 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+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession+ build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions+ let ff = ServerHello sh : build [ServerHelloDone]+ sendPacket12 ctx $ Handshake ff []+ contextFlush ctx+ Just sessionData -> do+ usingState_ ctx $ do+ setSession chSession+ setTLS12SessionResuming True+ sh <-+ makeServerHello sparams ctx usedCipher mcred chExtensions chSession+ 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 -> ClientHello -> IO (Maybe SessionData)+recoverSessionData ctx CH{..} = do+ serverName <- usingState_ ctx getClientSNI+ ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions+ let mticket =+ 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+ :: Context+ -> [CipherId]+ -> Maybe HostName+ -> Bool+ -> Maybe SessionData+ -> IO (Maybe SessionData)+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+ | 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"+ in throwCore $ Error_Protocol err HandshakeFailure+ | otherwise = return m+ where+ emsSession = SessionEMS `elem` sessionFlags sd++sendServerFirstFlight+ :: ServerParams+ -> Context+ -> Cipher+ -> Maybe Credential+ -> [ExtensionRaw]+ -> IO ([Handshake] -> [Handshake])+sendServerFirstFlight ServerParams{..} ctx usedCipher mcred chExts = do+ let b0 = id+ let cc = case mcred of+ Just (srvCerts, _) -> srvCerts+ _ -> CertificateChain []+ let b1 = b0 . (Certificate (CertificateChain_ cc) :)+ usingState_ ctx $ setServerCertificateChain cc++ -- send server key exchange if needed+ skx <- case cipherKeyExchange usedCipher of+ CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon+ CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA+ CipherKeyExchange_DHE_DSA -> Just <$> generateSKX_DHE KX_DSA+ CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA+ CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA+ _ -> return Nothing+ let b2 = case skx of+ Nothing -> b1+ Just kx -> b1 . (ServerKeyXchg kx :)++ -- FIXME we don't do this on a Anonymous server++ -- When configured, send a certificate request with the DNs of all+ -- configured CA certificates.+ --+ -- Client certificates MUST NOT be accepted if not requested.+ --+ if serverWantClientCert+ then do+ let (certTypes, hashSigs) =+ let as = supportedHashSignatures serverSupported+ in (nub $ mapMaybe hashSigToCertType as, as)+ creq =+ CertRequest+ certTypes+ hashSigs+ (map extractCAname serverCACertificates)+ usingHState ctx $ setCertReqSent True+ return $ b2 . (creq :)+ else return b2+ where+ commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts+ commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts+ setup_DHE = do+ let possibleFFGroups = commonGroups `intersect` availableFFGroups+ (dhparams, priv, pub) <-+ case possibleFFGroups of+ [] ->+ let dhparams = fromJust serverDHEParams+ in case findFiniteFieldGroup dhparams of+ Just g -> do+ usingHState ctx $ setSupportedGroup g+ generateFFDHE ctx g+ Nothing -> do+ (priv, pub) <- generateDHE ctx dhparams+ return (dhparams, priv, pub)+ g : _ -> do+ usingHState ctx $ setSupportedGroup g+ generateFFDHE ctx g++ let serverParams = serverDHParamsFrom dhparams pub++ usingHState ctx $ setServerDHParams serverParams+ usingHState ctx $ setDHPrivate priv+ return serverParams++ -- Choosing a hash algorithm to sign (EC)DHE parameters+ -- in ServerKeyExchange. Hash algorithm is not suggested by+ -- the chosen cipher suite. So, it should be selected based on+ -- the "signature_algorithms" extension in a client hello.+ -- If RSA is also used for key exchange, this function is+ -- not called.+ decideHashSig pubKey = do+ case filter (pubKey `signatureCompatible`) commonHashSigs of+ [] -> error ("no hash signature for " ++ pubkeyType pubKey)+ x : _ -> return x++ generateSKX_DHE kxsAlg = do+ serverParams <- setup_DHE+ pubKey <- getLocalPublicKey ctx+ mhashSig <- decideHashSig pubKey+ signed <- digitallySignDHParams ctx serverParams pubKey mhashSig+ case kxsAlg of+ KX_RSA -> return $ SKX_DHE_RSA serverParams signed+ KX_DSA -> return $ SKX_DHE_DSA serverParams signed+ _ ->+ error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg)++ generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE++ setup_ECDHE grp = do+ usingHState ctx $ setSupportedGroup grp+ (srvpri, srvpub) <- generateGroup ctx grp+ let serverParams = ServerECDHParams grp srvpub+ usingHState ctx $ setServerECDHParams serverParams+ usingHState ctx $ setGroupPrivate [(grp, srvpri)]+ return serverParams++ generateSKX_ECDHE kxsAlg = do+ let possibleECGroups = commonGroups `intersect` availableECGroups+ grp <- case possibleECGroups of+ [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure+ g : _ -> return g+ serverParams <- setup_ECDHE grp+ pubKey <- getLocalPublicKey ctx+ mhashSig <- decideHashSig pubKey+ signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig+ case kxsAlg of+ KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed+ KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed+ _ ->+ error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg)++---+-- When the client sends a certificate, check whether+-- it is acceptable for the application.+--+---+makeServerHello+ :: ServerParams+ -> Context+ -> Cipher+ -> Maybe Credential+ -> [ExtensionRaw]+ -> Session+ -> IO ServerHello+makeServerHello sparams ctx usedCipher mcred chExts session = do+ resuming <- usingState_ ctx getTLS12SessionResuming+ case mcred of+ Just cred -> storePrivInfoServer ctx cred+ _ -> return () -- return a sensible error+ sniExt <- do+ if resuming+ then return Nothing+ else do+ msni <- usingState_ ctx getClientSNI+ 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 _ -> 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++ let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams+ sessionTicketExt+ | not resuming && useTicket = 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)+ ++ catMaybes+ [ {- 0x00 -} sniExt+ , {- 0x0b -} ecPointExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0xff01 -} secureRenegExt+ ]+ usingState_ ctx $ setVersion TLS12+ setServerHelloParameters12 ctx TLS12 srand usedCipher nullCompression+ return $+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = session+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ }++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
@@ -0,0 +1,367 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Server.ServerHello13 (+ sendServerHello13,+ sendHRR,+) where++import Control.Monad.State.Strict++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Credentials+import Network.TLS.Crypto+import Network.TLS.Extension+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Control+import Network.TLS.Handshake.Key+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.Handshake.TranscriptHash+import Network.TLS.IO+import Network.TLS.Imports+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types+import Network.TLS.X509++sendServerHello13+ :: ServerParams+ -> Context+ -> KeyShareEntry+ -> (Cipher, Hash, Bool) -- rtt0+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ -> ClientHello+ -> Maybe ClientRandom+ -> IO+ ( SecretTriple ApplicationSecret+ , ClientTrafficSecret HandshakeSecret+ , Bool -- authenticated+ , Bool -- rtt0OK+ )+sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) 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+ setTLS13ClientSupportsPHA supportsPHA+ usingHState ctx $ do+ setSupportedGroup $ keyShareEntryGroup clientKeyShare+ setOuterClientRandom mOuterClientRandom+ hrr <- usingState_ ctx getTLS13HRR+ alpnExt <- applicationProtocol ctx chExtensions sparams+ setServerParameter+ let rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+ extraCreds <-+ usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)+ let p = makeCredentialPredicate TLS13 chExtensions+ allCreds =+ filterCredentials (isCredentialAllowed TLS13 p) $+ extraCreds `mappend` sharedCredentials (ctxShared ctx)+ ----------------------------------------------------------------+ established <- ctxEstablished ctx+ if established /= NotEstablished+ then+ if rtt0OK+ then do+ usingHState ctx $ setTLS13HandshakeMode RTT0+ usingHState ctx $ setTLS13RTT0Status RTT0Accepted+ else do+ usingHState ctx $ setTLS13HandshakeMode PreSharedKey+ usingHState ctx $ setTLS13RTT0Status RTT0Rejected+ else when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey+ -- else : FullHandshake or HelloRetryRequest+ mCredInfo <-+ if authenticated then return Nothing else decideCredentialInfo allCreds+ (ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare+ ensureRecvComplete ctx+ (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do+ sendServerHello keyShare+ sendChangeCipherSpec13 ctx+ ----------------------------------------------------------------+ handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe+ let serverHandshakeSecret = triServer handKey+ clientHandshakeSecret = triClient handKey+ handSecret = triBase handKey+ liftIO $ do+ if rtt0OK && not (ctxQUICMode ctx)+ then setRxRecordState ctx usedHash usedCipher clientEarlySecret+ else setRxRecordState ctx usedHash usedCipher clientHandshakeSecret+ setTxRecordState ctx usedHash usedCipher serverHandshakeSecret+ let mEarlySecInfo+ | rtt0OK = Just $ EarlySecretInfo usedCipher clientEarlySecret+ | otherwise = Nothing+ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret)+ contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo+ ----------------------------------------------------------------+ liftIO $ enablePeerRecordLimit ctx+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt+ case mCredInfo of+ Nothing -> return ()+ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib+ let ServerTrafficSecret shs = serverHandshakeSecret+ rawFinished <- makeFinished ctx usedHash shs+ loadPacket13 ctx $ Handshake13 [rawFinished] []+ return (clientHandshakeSecret, handSecret)+ ----------------------------------------------------------------+ hChSf <- transcriptHash ctx "CH..SF"+ appKey <- calculateApplicationSecret ctx choice handSecret hChSf+ let clientApplicationSecret0 = triClient appKey+ serverApplicationSecret0 = triServer appKey+ setTxRecordState ctx usedHash usedCipher serverApplicationSecret0+ let appSecInfo = ApplicationSecretInfo (clientApplicationSecret0, serverApplicationSecret0)+ contextSync ctx $ SendServerFinished appSecInfo+ ----------------------------------------------------------------+ when rtt0OK $ setEstablished ctx (EarlyDataAllowed rtt0max)+ return (appKey, clientHandshakeSecret, authenticated, rtt0OK)+ where+ choice = makeCipherChoice TLS13 usedCipher++ setServerParameter = do+ usingState_ ctx $ setVersion TLS13+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher False++ supportsPHA =+ lookupAndDecode+ EID_PostHandshakeAuth+ MsgTClientHello+ chExtensions+ False+ (\PostHandshakeAuth -> True)++ rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams+ rtt0accept = serverEarlyDataSize sparams > 0++ decideCredentialInfo allCreds = do+ 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+ -- RFC 8446 section 4.4.2.2).+ let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx+ hashSigs = sHashSigs `intersect` cHashSigs+ cltCreds = filterCredentialsWithHashSignatures chExtensions allCreds+ case credentialsFindForSigning13 hashSigs cltCreds of+ Nothing ->+ case credentialsFindForSigning13 hashSigs allCreds of+ Nothing -> throwCore $ Error_Protocol "credential not found" HandshakeFailure+ mcs -> return mcs+ mcs -> return mcs++ 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 zlib = do+ storePrivInfoServer ctx cred+ when (serverWantClientCert sparams) $ do+ let certReqCtx = "" -- this must be zero length here.+ certReq = makeCertRequest sparams ctx certReqCtx True+ loadPacket13 ctx $ Handshake13 [certReq] []+ usingHState ctx $ setCertReqSent True++ let CertificateChain cs = certChain+ ess = replicate (length cs) []+ let certtag = if zlib then CompressedCertificate13 else Certificate13+ loadPacket13 ctx $+ Handshake13 [certtag "" (CertificateChain_ certChain) ess] []+ liftIO $ usingState_ ctx $ setServerCertificateChain certChain+ hChSc <- transcriptHash ctx "CH..SC"+ pubkey <- getLocalPublicKey ctx+ vrfy <- makeCertVerify ctx pubkey hashSig hChSc+ loadPacket13 ctx $ Handshake13 [vrfy] []++ sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do+ msni <- liftIO $ usingState_ ctx getClientSNI+ 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 $ toExtensionRaw $ ServerName []+ Nothing -> Nothing++ mgroup <- usingHState ctx getSupportedGroup+ let serverGroups = supportedGroups (ctxSupported ctx)+ 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 $+ toExtensionRaw $+ ECHEncryptedExtensions $+ sharedECHConfigList $+ serverShared sparams+ | otherwise = Nothing+ let eeExtensions =+ sharedHelloExtensions (serverShared sparams)+ ++ catMaybes+ [ {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x10 -} alpnExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x2a -} earlyDataExt+ , {- 0xfe0d -} echExt+ ]+ eeExtensions' <-+ liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions+ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] []++credentialsFindForSigning13+ :: [HashAndSignatureAlgorithm]+ -> Credentials+ -> Maybe (Credential, HashAndSignatureAlgorithm)+credentialsFindForSigning13 hss0 creds = loop hss0+ where+ loop [] = Nothing+ loop (hs : hss) = case credentialsFindForSigning13' hs creds of+ Nothing -> loop hss+ Just cred -> Just (cred, hs)++-- See credentialsFindForSigning.+credentialsFindForSigning13'+ :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential+credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l+ where+ forSigning cred = case credentialDigitalSignatureKey cred of+ Nothing -> False+ Just pub -> pub `signatureCompatible13` sigAlg++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
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.Server.TLS12 (+ recvClientSecondFlight12,+) 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.Handshake.Common+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Server.Common+import Network.TLS.Handshake.Signature+import Network.TLS.Handshake.State+import Network.TLS.IO+import Network.TLS.Imports+import Network.TLS.Packet hiding (getSession)+import Network.TLS.Parameters+import Network.TLS.Session+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Types+import Network.TLS.X509 hiding (Certificate)++----------------------------------------------------------------++recvClientSecondFlight12+ :: ServerParams+ -> Context+ -> Maybe SessionData+ -> IO ()+recvClientSecondFlight12 sparams ctx resumeSessionData = do+ case resumeSessionData of+ Nothing -> do+ recvClientCCC sparams ctx+ mticket <- sessionEstablished ctx+ case mticket of+ Nothing -> return ()+ Just ticket -> do+ let life = adjustLifetime $ serverTicketLifetime sparams+ sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] []+ sendCCSandFinished ctx ServerRole+ Just _ -> do+ _ <- sessionEstablished ctx+ recvCCSandFinished ctx+ finishHandshake12 ctx+ where+ adjustLifetime i+ | i < 0 = 0+ | i > 604800 = 604800+ | otherwise = fromIntegral i++sessionEstablished :: Context -> IO (Maybe Ticket)+sessionEstablished ctx = do+ session <- usingState_ ctx getSession+ -- only callback the session established if we have a session+ case session of+ 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'+ (fromJust sessionData)+ _ -> return Nothing -- never reach++----------------------------------------------------------------++-- | receive Client data in handshake until the Finished handshake.+--+-- <- [certificate]+-- <- client key xchg+-- <- [cert verify]+-- <- change cipher+-- <- finish+recvClientCCC :: ServerParams -> Context -> IO ()+recvClientCCC sparams ctx = runRecvState ctx (RecvStateHandshake expectClientCertificate)+ where+ expectClientCertificate (Certificate (CertificateChain_ certs)) = do+ clientCertificate sparams ctx certs+ processCertificate ctx ServerRole certs++ -- FIXME: We should check whether the certificate+ -- matches our request and that we support+ -- verifying with that certificate.++ return $ RecvStateHandshake $ expectClientKeyExchange True+ expectClientCertificate p = expectClientKeyExchange False p++ -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,+ -- so we must process any packet, and in case of handshake call processHandshake manually.+ expectClientKeyExchange followedCertVerify (ClientKeyXchg ckx) = do+ processClientKeyXchg ctx ckx+ if followedCertVerify+ then return $ RecvStateHandshake expectCertificateVerify+ else return $ RecvStatePacket $ expectChangeCipherSpec ctx+ expectClientKeyExchange _ p = unexpected (show p) (Just "client key exchange")++ expectCertificateVerify (CertVerify dsig) = do+ certs <- checkValidClientCertChain ctx "change cipher message expected"++ usedVersion <- usingState_ ctx getVersion+ -- Fetch all handshake messages up to now.+ msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages++ pubKey <- usingHState ctx getRemotePublicKey+ checkDigitalSignatureKey usedVersion pubKey++ verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig+ processClientCertVerify sparams ctx certs verif+ return $ RecvStatePacket $ expectChangeCipherSpec ctx+ expectCertificateVerify p = unexpected (show p) (Just "client certificate verify")++----------------------------------------------------------------++expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO)+expectChangeCipherSpec ctx ChangeCipherSpec = do+ enableMyRecordLimit ctx+ return $ RecvStateHandshake $ expectFinished ctx+expectChangeCipherSpec _ p = unexpected (show p) (Just "change cipher")++----------------------------------------------------------------++-- process the client key exchange message. the protocol expects the initial+-- client version received in ClientHello, not the negotiated version.+-- in case the version mismatch, generate a random main secret+processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO ()+processClientKeyXchg ctx (CKX_RSA encryptedPreMain) = do+ (rver, role, random) <- usingState_ ctx $ do+ (,,) <$> getVersion <*> getRole <*> genRandom 48+ ePreMain <- decryptRSA ctx encryptedPreMain+ 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+ role <- usingState_ ctx getRole++ serverParams <- usingHState ctx getServerDHParams+ let params = serverDHParamsToParams serverParams+ unless (dhValid params $ dhUnwrapPublic clientDHValue) $+ throwCore $+ Error_Protocol "invalid client public key" IllegalParameter++ dhpriv <- usingHState ctx getDHPrivate+ let preMain = dhGetShared params dhpriv clientDHValue+ mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain+ logKey ctx (MainSecret mainSecret)+processClientKeyXchg ctx (CKX_ECDH bytes) = do+ ServerECDHParams grp _ <- usingHState ctx getServerECDHParams+ case groupDecodePublicB grp bytes of+ Left _ ->+ throwCore $+ Error_Protocol "client public key cannot be decoded" IllegalParameter+ Right clipub -> do+ 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++----------------------------------------------------------------++processClientCertVerify+ :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()+processClientCertVerify _sparams ctx certs True = do+ -- When verification succeeds, commit the+ -- client certificate chain to the context.+ --+ usingState_ ctx $ setClientCertificateChain certs+ return ()+processClientCertVerify sparams ctx certs False = do+ -- Either verification failed because of an+ -- invalid format (with an error message), or+ -- the signature is wrong. In either case,+ -- ask the application if it wants to+ -- proceed, we will do that.+ res <- onUnverifiedClientCert (serverHooks sparams)+ if res+ then do+ -- When verification fails, but the+ -- application callbacks accepts, we+ -- also commit the client certificate+ -- chain to the context.+ usingState_ ctx $ setClientCertificateChain certs+ else decryptError "verification failed"++----------------------------------------------------------------++recvCCSandFinished :: Context -> IO ()+recvCCSandFinished ctx = runRecvState ctx $ RecvStatePacket $ expectChangeCipherSpec ctx
+ Network/TLS/Handshake/Server/TLS13.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.TLS.Handshake.Server.TLS13 (+ recvClientSecondFlight13,+ requestCertificateServer,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..),+) where++import Control.Exception+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.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.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+ -> ( SecretTriple ApplicationSecret+ , ClientTrafficSecret HandshakeSecret+ , Bool+ , Bool+ )+ -> ClientHello+ -> IO ()+recvClientSecondFlight13 sparams ctx (appKey, clientHandshakeSecret, authenticated, rtt0OK) CH{..} = do+ sfSentTime <- getCurrentTimeFromBase+ let expectFinished' =+ 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 "CertVerify" (expectCertVerify sparams ctx)+ recvHandshake13hash ctx "Finished" expectFinished'+ ensureRecvComplete ctx+ else+ if rtt0OK && not (ctxQUICMode ctx)+ then+ setPendingRecvActions+ ctx+ [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret+ , PendingRecvActionHash True $+ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime+ ]+ else runRecvHandshake13 $ do+ recvHandshake13hash ctx "Finished" expectFinished'+ ensureRecvComplete ctx++expectFinished+ :: MonadIO m+ => ServerParams+ -> Context+ -> [ExtensionRaw]+ -> SecretTriple ApplicationSecret+ -> ClientTrafficSecret HandshakeSecret+ -> Word64+ -> TranscriptHash+ -> Handshake13+ -> m ()+expectFinished sparams ctx exts appKey clientHandshakeSecret sfSentTime hChBeforeCf (Finished13 verifyData) = liftIO $ do+ modifyTLS13State ctx $ \st -> st{tls13stRecvCF = True}+ (usedHash, usedCipher, _, _) <- getRxRecordState ctx+ let ClientTrafficSecret chs = clientHandshakeSecret+ checkFinished ctx usedHash chs hChBeforeCf verifyData+ finishHandshake13 ctx+ setRxRecordState ctx usedHash usedCipher clientApplicationSecret0+ sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime+ where+ applicationSecret = triBase appKey+ clientApplicationSecret0 = triClient appKey+expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13")++expectEndOfEarlyData+ :: Context+ -> ClientTrafficSecret HandshakeSecret+ -> Handshake13+ -> IO ()+expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do+ (usedHash, usedCipher, _, _) <- getRxRecordState ctx+ setRxRecordState ctx usedHash usedCipher clientHandshakeSecret+expectEndOfEarlyData _ _ hs = unexpected (show hs) (Just "end of early data")++expectCertificate+ :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool+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+ :: ServerParams+ -> Context+ -> Cipher+ -> [ExtensionRaw]+ -> BaseSecret ApplicationSecret+ -> Word64+ -> IO ()+sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime = when sendNST $ do+ cfRecvTime <- getCurrentTimeFromBase+ let rtt = cfRecvTime - sfSentTime+ 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] []+ where+ choice = makeCipherChoice TLS13 usedCipher+ rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams+ sendNST = PSK_DHE_KE `elem` dhModes++ dhModes = case extensionLookup EID_PskKeyExchangeModes exts+ >>= extensionDecode MsgTClientHello of+ Just (PskKeyExchangeModes ms) -> ms+ Nothing -> []++ generateSession life psk maxSize rtt = do+ Session (Just sessionId) <- newSession ctx+ tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt)+ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk+ let mgr = sharedSessionManager $ serverShared sparams+ mticket <- sessionEstablish mgr sessionId sdata+ let identity = SessionIDorTicket_ $ fromMaybe sessionId mticket+ return (identity, ageAdd tinfo)++ createNewSessionTicket life add nonce identity maxSize =+ NewSessionTicket13 life add nonce identity nstExtensions+ where+ 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 -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do+ certs@(CertificateChain cc) <-+ checkValidClientCertChain ctx "invalid client certificate chain"+ pubkey <- case cc of+ [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure+ c : _ -> return $ certPubKey $ getCertificate c+ ver <- usingState_ ctx getVersion+ checkDigitalSignatureKey ver pubkey+ usingHState ctx $ setPublicKey pubkey+ verif <- checkCertVerify ctx pubkey sigAlg sig hChCc+ clientCertVerify sparams ctx certs verif+expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13")++clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()+clientCertVerify sparams ctx certs verif = do+ if verif+ then do+ -- When verification succeeds, commit the+ -- client certificate chain to the context.+ --+ usingState_ ctx $ setClientCertificateChain certs+ return ()+ else do+ -- Either verification failed because of an+ -- invalid format (with an error message), or+ -- the signature is wrong. In either case,+ -- ask the application if it wants to+ -- proceed, we will do that.+ res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)+ if res+ then do+ -- When verification fails, but the+ -- application callbacks accepts, we+ -- also commit the client certificate+ -- chain to the context.+ usingState_ ctx $ setClientCertificateChain certs+ else decryptError "verification failed"++----------------------------------------------------------------++newCertReqContext :: Context -> IO CertReqContext+newCertReqContext ctx = getStateRNG ctx 32++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+ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ sendPacket13 ctx $ Handshake13 [certReq13] []+ withReadLock ctx $ do+ (clientCert13, bClientCert13) <- getHandshake ctx ref+ emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13+ baseHState <- saveHState ctx+ updateTranscriptHash13 ctx (clientCert13, bClientCert13)+ th <- transcriptHash ctx "CH..Cert"+ unless emptyCert $ do+ (certVerify13, bCertVerify13) <- getHandshake ctx ref+ expectCertVerify sparams ctx th certVerify13+ updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+ (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+ 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++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+ throwIO $ Terminated False reason err++handleEx :: Context -> IO Bool -> IO Bool+handleEx ctx f = catchException f $ \exception -> do+ -- If the error was an Uncontextualized TLSException, we replace the+ -- context with HandshakeFailed. If it's anything else, we convert+ -- it to a string and wrap it with Error_Misc and HandshakeFailed.+ let tlserror = case fromException exception of+ Just e | Uncontextualized e' <- e -> e'+ _ -> Error_Misc (show exception)+ sendPacket13 ctx $ Alert13 [errorToAlert tlserror]+ void $ 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
@@ -1,70 +1,64 @@ {-# LANGUAGE OverloadedStrings #-}--- |--- Module : Network.TLS.Handshake.Signature--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.Signature- (- createCertificateVerify- , checkCertificateVerify- , digitallySignDHParams- , digitallySignECDHParams- , digitallySignDHParamsVerify- , digitallySignECDHParamsVerify- , checkSupportedHashSignature- , certificateCompatible- , signatureCompatible- , signatureCompatible13- , hashSigToCertType- , signatureParams- , decryptError- ) where -import Network.TLS.Crypto+module Network.TLS.Handshake.Signature (+ createCertificateVerify,+ checkCertificateVerify,+ digitallySignDHParams,+ digitallySignECDHParams,+ digitallySignDHParamsVerify,+ digitallySignECDHParamsVerify,+ checkSupportedHashSignature,+ certificateCompatible,+ signatureCompatible,+ signatureCompatible13,+ hashSigToCertType,+ signatureParams,+ decryptError,+) where++import Control.Monad.State.Strict+ import Network.TLS.Context.Internal-import Network.TLS.Parameters-import Network.TLS.Struct+import Network.TLS.Crypto+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.State import Network.TLS.Imports-import Network.TLS.Packet (generateCertificateVerify_SSL, generateCertificateVerify_SSL_DSS,- encodeSignedDHParams, encodeSignedECDHParams)+import Network.TLS.Packet (+ encodeSignedDHParams,+ encodeSignedECDHParams,+ )+import Network.TLS.Parameters import Network.TLS.State-import Network.TLS.Handshake.State-import Network.TLS.Handshake.Key-import Network.TLS.Util+import Network.TLS.Struct import Network.TLS.X509 -import Control.Monad.State.Strict- decryptError :: MonadIO m => String -> m a-decryptError msg = throwCore $ Error_Protocol (msg, True, DecryptError)+decryptError msg = throwCore $ Error_Protocol msg DecryptError -- | Check that the key is compatible with a list of 'CertificateType' values. -- Ed25519 and Ed448 have no assigned code point and are checked with extension -- "signature_algorithms" only. certificateCompatible :: PubKey -> [CertificateType] -> Bool-certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes-certificateCompatible (PubKeyDSA _) cTypes = CertificateType_DSS_Sign `elem` cTypes-certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes-certificateCompatible (PubKeyEd25519 _) _ = True-certificateCompatible (PubKeyEd448 _) _ = True-certificateCompatible _ _ = False+certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes+certificateCompatible (PubKeyDSA _) cTypes = CertificateType_DSA_Sign `elem` cTypes+certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes+certificateCompatible (PubKeyEd25519 _) _ = True+certificateCompatible (PubKeyEd448 _) _ = True+certificateCompatible _ _ = False signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool-signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1-signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256-signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384-signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512-signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256-signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384-signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512-signatureCompatible (PubKeyDSA _) (_, SignatureDSS) = True-signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True-signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True-signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True-signatureCompatible _ (_, _) = False+signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1+signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256+signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384+signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512+signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256+signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384+signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512+signatureCompatible (PubKeyDSA _) (_, SignatureDSA) = True+signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True+signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True+signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True+signatureCompatible _ (_, _) = False -- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the -- relation between hash in the HashAndSignatureAlgorithm and elliptic curve@@ -75,7 +69,7 @@ hashCurve HashSHA256 = Just P256 hashCurve HashSHA384 = Just P384 hashCurve HashSHA512 = Just P521- hashCurve _ = Nothing+ hashCurve _ = Nothing signatureCompatible13 pub hs = signatureCompatible pub hs -- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'.@@ -96,55 +90,52 @@ -- @RSA@ as the only supported client certificate algorithm for TLS 1.3. -- -- FIXME: Add RSA_PSS_PSS signatures when supported.--- hashSigToCertType :: HashAndSignatureAlgorithm -> Maybe CertificateType ---hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign+hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign ---hashSigToCertType (_, SignatureDSS) = Just CertificateType_DSS_Sign+hashSigToCertType (_, SignatureDSA) = Just CertificateType_DSA_Sign -- hashSigToCertType (_, SignatureECDSA) = Just CertificateType_ECDSA_Sign ---hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA256)- = Just CertificateType_RSA_Sign-hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA384)- = Just CertificateType_RSA_Sign-hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA512)- = Just CertificateType_RSA_Sign-hashSigToCertType (HashIntrinsic, SignatureEd25519)- = Just CertificateType_Ed25519_Sign-hashSigToCertType (HashIntrinsic, SignatureEd448)- = Just CertificateType_Ed448_Sign+hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA256) =+ Just CertificateType_RSA_Sign+hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA384) =+ Just CertificateType_RSA_Sign+hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA512) =+ Just CertificateType_RSA_Sign+hashSigToCertType (HashIntrinsic, SignatureEd25519) =+ Just CertificateType_Ed25519_Sign+hashSigToCertType (HashIntrinsic, SignatureEd448) =+ Just CertificateType_Ed448_Sign -- hashSigToCertType _ = Nothing -checkCertificateVerify :: Context- -> Version- -> PubKey- -> ByteString- -> DigitallySigned- -> IO Bool-checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) =- case (usedVersion, hashSigAlg) of- (TLS12, Nothing) -> return False- (TLS12, Just hs) | pubKey `signatureCompatible` hs -> doVerify- | otherwise -> return False- (_, Nothing) -> doVerify- (_, Just _) -> return False+checkCertificateVerify+ :: Context+ -> Version+ -> PubKey+ -> ByteString+ -> DigitallySigned+ -> IO Bool+checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _)+ | pubKey `signatureCompatible` hashSigAlg = doVerify+ | otherwise = return False where doVerify =- prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>=- signatureVerifyWithCertVerifyData ctx digSig+ prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs+ >>= signatureVerifyWithCertVerifyData ctx digSig -createCertificateVerify :: Context- -> Version- -> PubKey- -> Maybe HashAndSignatureAlgorithm -- TLS12 only- -> ByteString- -> IO DigitallySigned+createCertificateVerify+ :: Context+ -> Version+ -> PubKey+ -> HashAndSignatureAlgorithm -- TLS12 only+ -> ByteString+ -> IO DigitallySigned createCertificateVerify ctx usedVersion pubKey hashSigAlg msgs =- prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>=- signatureCreateWithCertVerifyData ctx hashSigAlg+ prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs+ >>= signatureCreateWithCertVerifyData ctx hashSigAlg type CertVerifyData = (SignatureParams, ByteString) @@ -152,149 +143,163 @@ -- the SHA1_MD5 algorithm expect an already digested data buildVerifyData :: SignatureParams -> ByteString -> CertVerifyData buildVerifyData (RSAParams SHA1_MD5 enc) bs = (RSAParams SHA1_MD5 enc, hashFinal $ hashUpdate (hashInit SHA1_MD5) bs)-buildVerifyData sigParam bs = (sigParam, bs)+buildVerifyData sigParam bs = (sigParam, bs) -prepareCertificateVerifySignatureData :: Context- -> Version- -> PubKey- -> Maybe HashAndSignatureAlgorithm -- TLS12 only- -> ByteString- -> IO CertVerifyData-prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs- | usedVersion == SSL3 = do- (hashCtx, params, generateCV_SSL) <-- case pubKey of- PubKeyRSA _ -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL)- PubKeyDSA _ -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS)- _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ pubkeyType pubKey)- Just masterSecret <- usingHState ctx $ gets hstMasterSecret- return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs)- | usedVersion == TLS10 || usedVersion == TLS11 =- return $ buildVerifyData (signatureParams pubKey Nothing) msgs- | otherwise = return (signatureParams pubKey hashSigAlg, msgs)+prepareCertificateVerifySignatureData+ :: Context+ -> Version+ -> PubKey+ -> HashAndSignatureAlgorithm -- TLS12 only+ -> ByteString+ -> IO CertVerifyData+prepareCertificateVerifySignatureData _ctx _usedVersion pubKey hashSigAlg msgs =+ return (signatureParams pubKey hashSigAlg, msgs) -signatureParams :: PubKey -> Maybe HashAndSignatureAlgorithm -> SignatureParams+signatureParams :: PubKey -> HashAndSignatureAlgorithm -> SignatureParams signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of- Just (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1- Just (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1- Just (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1- Just (HashSHA1 , SignatureRSA) -> RSAParams SHA1 RSApkcs1- Just (HashIntrinsic , SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss- Just (HashIntrinsic , SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss- Just (HashIntrinsic , SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss- Nothing -> RSAParams SHA1_MD5 RSApkcs1- Just (hsh , SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh)- Just (_ , sigAlg) -> error ("signature algorithm is incompatible with RSA: " ++ show sigAlg)+ (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1+ (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1+ (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1+ (HashSHA1, SignatureRSA) -> RSAParams SHA1 RSApkcs1+ (HashIntrinsic, SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss+ (HashIntrinsic, SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss+ (HashIntrinsic, SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss+ (hsh, SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh)+ (_, sigAlg) ->+ error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of- Nothing -> DSSParams- Just (HashSHA1, SignatureDSS) -> DSSParams- Just (_ , SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed"- Just (_ , sigAlg) -> error ("signature algorithm is incompatible with DSS: " ++ show sigAlg)+ (HashSHA1, SignatureDSA) -> DSAParams+ (_, SignatureDSA) -> error "invalid DSA hash choice, only SHA1 allowed"+ (_, sigAlg) ->+ error ("signature algorithm is incompatible with DSA: " ++ show sigAlg) signatureParams (PubKeyEC _) hashSigAlg = case hashSigAlg of- Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512- Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384- Just (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256- Just (HashSHA1 , SignatureECDSA) -> ECDSAParams SHA1- Nothing -> ECDSAParams SHA1- Just (hsh , SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh)- Just (_ , sigAlg) -> error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg)+ (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512+ (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384+ (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256+ (HashSHA1, SignatureECDSA) -> ECDSAParams SHA1+ (hsh, SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh)+ (_, sigAlg) ->+ error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) signatureParams (PubKeyEd25519 _) hashSigAlg = case hashSigAlg of- Nothing -> Ed25519Params- Just (HashIntrinsic , SignatureEd25519) -> Ed25519Params- Just (hsh , SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh)- Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg)+ (HashIntrinsic, SignatureEd25519) -> Ed25519Params+ (hsh, SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh)+ (_, sigAlg) ->+ error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) signatureParams (PubKeyEd448 _) hashSigAlg = case hashSigAlg of- Nothing -> Ed448Params- Just (HashIntrinsic , SignatureEd448) -> Ed448Params- Just (hsh , SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh)- Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg)+ (HashIntrinsic, SignatureEd448) -> Ed448Params+ (hsh, SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh)+ (_, sigAlg) ->+ error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") -signatureCreateWithCertVerifyData :: Context- -> Maybe HashAndSignatureAlgorithm- -> CertVerifyData- -> IO DigitallySigned+signatureCreateWithCertVerifyData+ :: Context+ -> HashAndSignatureAlgorithm+ -> CertVerifyData+ -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do- cc <- usingState_ ctx isClientContext- DigitallySigned malg <$> signPrivate ctx cc sigParam toSign+ role <- usingState_ ctx getRole+ DigitallySigned malg <$> signPrivate ctx role sigParam toSign signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = do usedVersion <- usingState_ ctx getVersion let (sigParam, toVerify) = case (usedVersion, hashSigAlg) of- (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure"- (TLS12, Just hs) | pubKey `signatureCompatible` hs -> (signatureParams pubKey hashSigAlg, toVerifyData)- | otherwise -> error "expecting different signature algorithm"- (_, Nothing) -> buildVerifyData (signatureParams pubKey Nothing) toVerifyData- (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure"+ (TLS12, hs)+ | pubKey `signatureCompatible` hs ->+ (signatureParams pubKey hashSigAlg, toVerifyData)+ | otherwise ->+ error "expecting different signature algorithm"+ _ ->+ error+ "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) -signatureVerifyWithCertVerifyData :: Context- -> DigitallySigned- -> CertVerifyData- -> IO Bool+signatureVerifyWithCertVerifyData+ :: Context+ -> DigitallySigned+ -> CertVerifyData+ -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned hs bs) (sigParam, toVerify) = do checkSupportedHashSignature ctx hs verifyPublic ctx sigParam toVerify bs -digitallySignParams :: Context -> ByteString -> PubKey -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned+digitallySignParams+ :: Context+ -> ByteString+ -> PubKey+ -> HashAndSignatureAlgorithm+ -> IO DigitallySigned digitallySignParams ctx signatureData pubKey hashSigAlg = let sigParam = signatureParams pubKey hashSigAlg- in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData)+ in signatureCreateWithCertVerifyData+ ctx+ hashSigAlg+ (buildVerifyData sigParam signatureData) -digitallySignDHParams :: Context- -> ServerDHParams- -> PubKey- -> Maybe HashAndSignatureAlgorithm -- TLS12 only- -> IO DigitallySigned+digitallySignDHParams+ :: Context+ -> ServerDHParams+ -> PubKey+ -> HashAndSignatureAlgorithm -- TLS12 only+ -> IO DigitallySigned digitallySignDHParams ctx serverParams pubKey mhash = do- dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams+ dhParamsData <-+ withClientAndServerRandom ctx $ encodeSignedDHParams serverParams digitallySignParams ctx dhParamsData pubKey mhash -digitallySignECDHParams :: Context- -> ServerECDHParams- -> PubKey- -> Maybe HashAndSignatureAlgorithm -- TLS12 only- -> IO DigitallySigned+digitallySignECDHParams+ :: Context+ -> ServerECDHParams+ -> PubKey+ -> HashAndSignatureAlgorithm -- TLS12 only+ -> IO DigitallySigned digitallySignECDHParams ctx serverParams pubKey mhash = do- ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams+ ecdhParamsData <-+ withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams digitallySignParams ctx ecdhParamsData pubKey mhash -digitallySignDHParamsVerify :: Context- -> ServerDHParams- -> PubKey- -> DigitallySigned- -> IO Bool+digitallySignDHParamsVerify+ :: Context+ -> ServerDHParams+ -> PubKey+ -> DigitallySigned+ -> IO Bool digitallySignDHParamsVerify ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedDHParams dhparams signatureVerify ctx signature pubKey expectedData -digitallySignECDHParamsVerify :: Context- -> ServerECDHParams- -> PubKey- -> DigitallySigned- -> IO Bool+digitallySignECDHParamsVerify+ :: Context+ -> ServerECDHParams+ -> PubKey+ -> DigitallySigned+ -> IO Bool digitallySignECDHParamsVerify ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedECDHParams dhparams signatureVerify ctx signature pubKey expectedData -withClientAndServerRandom :: Context -> (ClientRandom -> ServerRandom -> b) -> IO b+withClientAndServerRandom+ :: Context -> (ClientRandom -> ServerRandom -> b) -> IO b withClientAndServerRandom ctx f = do- (cran, sran) <- usingHState ctx $ (,) <$> gets hstClientRandom- <*> (fromJust "withClientAndServer : server random" <$> gets hstServerRandom)+ (cran, sran) <-+ usingHState ctx $+ (,)+ <$> gets hstClientRandom+ <*> (fromJust <$> gets hstServerRandom) return $ f cran sran -- verify that the hash and signature selected by the peer is supported in -- the local configuration-checkSupportedHashSignature :: Context -> Maybe HashAndSignatureAlgorithm -> IO ()-checkSupportedHashSignature _ Nothing = return ()-checkSupportedHashSignature ctx (Just hs) =+checkSupportedHashSignature+ :: Context -> HashAndSignatureAlgorithm -> IO ()+checkSupportedHashSignature ctx hs = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ let msg = "unsupported hash and signature algorithm: " ++ show hs- in throwCore $ Error_Protocol (msg, True, IllegalParameter)+ in throwCore $ Error_Protocol msg IllegalParameter
Network/TLS/Handshake/State.hs view
@@ -1,519 +1,569 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}--- |--- Module : Network.TLS.Handshake.State--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.State- ( HandshakeState(..)- , HandshakeDigest(..)- , HandshakeMode13(..)- , RTT0Status(..)- , CertReqCBdata- , HandshakeM- , newEmptyHandshake- , runHandshake++module Network.TLS.Handshake.State (+ HandshakeState (..),+ TransHashState (..),+ HandshakeMode13 (..),+ RTT0Status (..),+ CertReqCBdata,+ HandshakeM,+ newEmptyHandshake,+ runHandshake,+ -- * key accessors- , setPublicKey- , setPublicPrivateKeys- , getLocalPublicPrivateKeys- , getRemotePublicKey- , setServerDHParams- , getServerDHParams- , setServerECDHParams- , getServerECDHParams- , setDHPrivate- , getDHPrivate- , setGroupPrivate- , getGroupPrivate+ setPublicKey,+ setPublicPrivateKeys,+ getLocalPublicPrivateKeys,+ getRemotePublicKey,+ setServerDHParams,+ getServerDHParams,+ setServerECDHParams,+ getServerECDHParams,+ setDHPrivate,+ getDHPrivate,+ setGroupPrivate,+ getGroupPrivate,+ -- * cert accessors- , setClientCertSent- , getClientCertSent- , setCertReqSent- , getCertReqSent- , setClientCertChain- , getClientCertChain- , setCertReqToken- , getCertReqToken- , setCertReqCBdata- , getCertReqCBdata- , setCertReqSigAlgsCert- , getCertReqSigAlgsCert+ setClientRandom,+ getClientRandom,+ setOuterClientRandom,+ getOuterClientRandom,+ setClientHello,+ getClientHello,+ setECHEE,+ getECHEE,+ setECHAccepted,+ getECHAccepted,+ setClientCertSent,+ getClientCertSent,+ setCertReqSent,+ getCertReqSent,+ setClientCertChain,+ getClientCertChain,+ setCertReqToken,+ getCertReqToken,+ setCertReqCBdata,+ getCertReqCBdata,+ setCertReqSigAlgsCert,+ getCertReqSigAlgsCert,+ -- * digest accessors- , addHandshakeMessage- , updateHandshakeDigest- , getHandshakeMessages- , getHandshakeMessagesRev- , getHandshakeDigest- , foldHandshakeDigest- -- * master secret- , setMasterSecret- , setMasterSecretFromPre+ addHandshakeMessage,+ getHandshakeMessages,++ -- * main secret+ setMainSecret,+ setMainSecretFromPre,+ -- * misc accessor- , getPendingCipher- , setServerHelloParameters- , setExtendedMasterSec- , getExtendedMasterSec- , setNegotiatedGroup- , getNegotiatedGroup- , setTLS13HandshakeMode- , getTLS13HandshakeMode- , setTLS13RTT0Status- , getTLS13RTT0Status- , setTLS13EarlySecret- , getTLS13EarlySecret- , setTLS13ResumptionSecret- , getTLS13ResumptionSecret- , setCCS13Sent- , getCCS13Sent- ) where+ getPendingCipher,+ setExtendedMainSecret,+ getExtendedMainSecret,+ setSupportedGroup,+ getSupportedGroup,+ setTLS13HandshakeMode,+ getTLS13HandshakeMode,+ setTLS13RTT0Status,+ getTLS13RTT0Status,+ setTLS13EarlySecret,+ getTLS13EarlySecret,+ setTLS13ResumptionSecret,+ getTLS13ResumptionSecret,+ setTLS13CertComp,+ getTLS13CertComp,+ setCCS13Sent,+ getCCS13Sent,+ setCCS13Recv,+ getCCS13Recv,+) where -import Network.TLS.Util-import Network.TLS.Struct-import Network.TLS.Record.State-import Network.TLS.Packet-import Network.TLS.Crypto+import Control.Monad.State.Strict+import Data.ByteArray (convert)+import Data.X509 (CertificateChain)+ import Network.TLS.Cipher import Network.TLS.Compression-import Network.TLS.Types+import Network.TLS.Crypto import Network.TLS.Imports-import Control.Monad.State.Strict-import Data.X509 (CertificateChain)-import Data.ByteArray (ByteArrayAccess)+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Struct+import Network.TLS.Types+import Network.TLS.Util data HandshakeKeyState = HandshakeKeyState- { hksRemotePublicKey :: !(Maybe PubKey)- , hksLocalPublicPrivateKeys :: !(Maybe (PubKey, PrivKey))- } deriving (Show)+ { hksRemotePublicKey :: Maybe PubKey+ , hksLocalPublicPrivateKeys :: Maybe (PubKey, PrivKey)+ }+ 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- , hstServerRandom :: !(Maybe ServerRandom)- , hstMasterSecret :: !(Maybe ByteString)- , hstKeyState :: !HandshakeKeyState- , hstServerDHParams :: !(Maybe ServerDHParams)- , hstDHPrivate :: !(Maybe DHPrivate)- , hstServerECDHParams :: !(Maybe ServerECDHParams)- , hstGroupPrivate :: !(Maybe GroupPrivate)- , hstHandshakeDigest :: !HandshakeDigest- , hstHandshakeMessages :: [ByteString]- , hstCertReqToken :: !(Maybe ByteString)- -- ^ Set to Just-value when a TLS13 certificate request is received- , hstCertReqCBdata :: !(Maybe CertReqCBdata)- -- ^ Set to Just-value when a certificate request is received- , hstCertReqSigAlgsCert :: !(Maybe [HashAndSignatureAlgorithm])- -- ^ In TLS 1.3, these are separate from the certificate- -- issuer signature algorithm hints in the callback data.- -- In TLS 1.2 the same list is overloaded for both purposes.- -- Not present in TLS 1.1 and earlier- , hstClientCertSent :: !Bool- -- ^ Set to true when a client certificate chain was sent- , hstCertReqSent :: !Bool- -- ^ Set to true when a certificate request was sent. This applies- -- only to requests sent during handshake (not post-handshake).- , hstClientCertChain :: !(Maybe CertificateChain)- , hstPendingTxState :: Maybe RecordState- , hstPendingRxState :: Maybe RecordState- , hstPendingCipher :: Maybe Cipher- , hstPendingCompression :: Compression- , hstExtendedMasterSec :: Bool- , hstNegotiatedGroup :: Maybe Group- , hstTLS13HandshakeMode :: HandshakeMode13- , hstTLS13RTT0Status :: !RTT0Status- , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret)+ { hstClientVersion :: Version+ , hstClientRandom :: ClientRandom+ -- ^ For ECH, inner client random.+ , hstServerRandom :: Maybe ServerRandom+ , hstMainSecret :: Maybe Secret+ , hstKeyState :: HandshakeKeyState+ , hstServerDHParams :: Maybe ServerDHParams+ , hstDHPrivate :: Maybe DHPrivate+ , hstServerECDHParams :: Maybe ServerECDHParams+ , 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+ -- ^ Set to Just-value when a certificate request is received+ , hstCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm]+ -- ^ In TLS 1.3, these are separate from the certificate+ -- issuer signature algorithm hints in the callback data.+ -- In TLS 1.2 the same list is overloaded for both purposes.+ -- Not present in TLS 1.1 and earlier+ , hstClientCertSent :: Bool+ -- ^ Set to true when a client certificate chain was sent+ , hstCertReqSent :: Bool+ -- ^ Set to true when a certificate request was sent. This applies+ -- only to requests sent during handshake (not post-handshake).+ , hstClientCertChain :: Maybe CertificateChain+ , hstPendingTxState :: Maybe RecordState+ , hstPendingRxState :: Maybe RecordState+ , hstPendingCipher :: Maybe Cipher+ , hstPendingCompression :: Compression+ , hstExtendedMainSecret :: Bool+ , hstSupportedGroup :: Maybe Group+ , hstTLS13HandshakeMode :: HandshakeMode13+ , hstTLS13RTT0Status :: RTT0Status+ , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret)- , hstCCS13Sent :: !Bool- } deriving (Show)--{- | When we receive a CertificateRequest from a server, a just-in-time- callback is issued to the application to obtain a suitable certificate.- Somewhat unfortunately, the callback parameters don't abstract away the- details of the TLS 1.2 Certificate Request message, which combines the- legacy @certificate_types@ and new @supported_signature_algorithms@- parameters is a rather subtle way.-- TLS 1.2 also (again unfortunately, in the opinion of the author of this- comment) overloads the signature algorithms parameter to constrain not only- the algorithms used in TLS, but also the algorithms used by issuing CAs in- the X.509 chain. Best practice is to NOT treat such that restriction as a- MUST, but rather take it as merely a preference, when a choice exists. If- the best chain available does not match the provided signature algorithm- list, go ahead and use it anyway, it will probably work, and the server may- not even care about the issuer CAs at all, it may be doing DANE or have- explicit mappings for the client's public key, ...-- The TLS 1.3 @CertificateRequest@ message, drops @certificate_types@ and no- longer overloads @supported_signature_algorithms@ to cover X.509. It also- includes a new opaque context token that the client must echo back, which- makes certain client authentication replay attacks more difficult. We will- store that context separately, it does not need to be presented in the user- callback. The certificate signature algorithms preferred by the peer are- now in the separate @signature_algorithms_cert@ extension, but we cannot- report these to the application callback without an API change. The good- news is that filtering the X.509 signature types is generally unnecessary,- unwise and difficult. So we just ignore this extension.-- As a result, the information we provide to the callback is no longer a- verbatim copy of the certificate request payload. In the case of TLS 1.3- The 'CertificateType' list is synthetically generated from the server's- @signature_algorithms@ extension, and the @signature_algorithms_certs@- extension is ignored.+ , 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) - Since the original TLS 1.2 'CertificateType' has no provision for the newer- certificate types that have appeared in TLS 1.3 we're adding some synthetic- values that have no equivalent values in the TLS 1.2 'CertificateType' as- defined in the IANA- <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-2- TLS ClientCertificateType Identifiers> registry. These values are inferred- from the TLS 1.3 @signature_algorithms@ extension, and will allow clients to- present Ed25519 and Ed448 certificates when these become supported.--}+-- | When we receive a CertificateRequest from a server, a just-in-time+-- callback is issued to the application to obtain a suitable certificate.+-- Somewhat unfortunately, the callback parameters don't abstract away the+-- details of the TLS 1.2 Certificate Request message, which combines the+-- legacy @certificate_types@ and new @supported_signature_algorithms@+-- parameters is a rather subtle way.+--+-- TLS 1.2 also (again unfortunately, in the opinion of the author of this+-- comment) overloads the signature algorithms parameter to constrain not only+-- the algorithms used in TLS, but also the algorithms used by issuing CAs in+-- the X.509 chain. Best practice is to NOT treat such that restriction as a+-- MUST, but rather take it as merely a preference, when a choice exists. If+-- the best chain available does not match the provided signature algorithm+-- list, go ahead and use it anyway, it will probably work, and the server may+-- not even care about the issuer CAs at all, it may be doing DANE or have+-- explicit mappings for the client's public key, ...+--+-- The TLS 1.3 @CertificateRequest@ message, drops @certificate_types@ and no+-- longer overloads @supported_signature_algorithms@ to cover X.509. It also+-- includes a new opaque context token that the client must echo back, which+-- makes certain client authentication replay attacks more difficult. We will+-- store that context separately, it does not need to be presented in the user+-- callback. The certificate signature algorithms preferred by the peer are+-- now in the separate @signature_algorithms_cert@ extension, but we cannot+-- report these to the application callback without an API change. The good+-- news is that filtering the X.509 signature types is generally unnecessary,+-- unwise and difficult. So we just ignore this extension.+--+-- As a result, the information we provide to the callback is no longer a+-- verbatim copy of the certificate request payload. In the case of TLS 1.3+-- The 'CertificateType' list is synthetically generated from the server's+-- @signature_algorithms@ extension, and the @signature_algorithms_certs@+-- extension is ignored.+--+-- Since the original TLS 1.2 'CertificateType' has no provision for the newer+-- certificate types that have appeared in TLS 1.3 we're adding some synthetic+-- values that have no equivalent values in the TLS 1.2 'CertificateType' as+-- defined in the IANA+-- <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-2+-- TLS ClientCertificateType Identifiers> registry. These values are inferred+-- from the TLS 1.3 @signature_algorithms@ extension, and will allow clients to+-- present Ed25519 and Ed448 certificates when these become supported. type CertReqCBdata =- ( [CertificateType]- , Maybe [HashAndSignatureAlgorithm]- , [DistinguishedName] )+ ( [CertificateType]+ , Maybe [HashAndSignatureAlgorithm]+ , [DistinguishedName]+ ) -newtype HandshakeM a = HandshakeM { runHandshakeM :: State HandshakeState a }+newtype HandshakeM a = HandshakeM {runHandshakeM :: State HandshakeState a} deriving (Functor, Applicative, Monad) instance MonadState HandshakeState HandshakeM where put x = HandshakeM (put x)- get = HandshakeM get+ get = HandshakeM get state f = HandshakeM (state f) -- create a new empty handshake state newEmptyHandshake :: Version -> ClientRandom -> HandshakeState-newEmptyHandshake ver crand = HandshakeState- { hstClientVersion = ver- , hstClientRandom = crand- , hstServerRandom = Nothing- , hstMasterSecret = Nothing- , hstKeyState = HandshakeKeyState Nothing Nothing- , hstServerDHParams = Nothing- , hstDHPrivate = Nothing- , hstServerECDHParams = Nothing- , hstGroupPrivate = Nothing- , hstHandshakeDigest = HandshakeMessages []- , hstHandshakeMessages = []- , hstCertReqToken = Nothing- , hstCertReqCBdata = Nothing- , hstCertReqSigAlgsCert = Nothing- , hstClientCertSent = False- , hstCertReqSent = False- , hstClientCertChain = Nothing- , hstPendingTxState = Nothing- , hstPendingRxState = Nothing- , hstPendingCipher = Nothing- , hstPendingCompression = nullCompression- , hstExtendedMasterSec = False- , hstNegotiatedGroup = Nothing- , hstTLS13HandshakeMode = FullHandshake- , hstTLS13RTT0Status = RTT0None- , hstTLS13EarlySecret = Nothing- , hstTLS13ResumptionSecret = Nothing- , hstCCS13Sent = False- }+newEmptyHandshake ver crand =+ HandshakeState+ { hstClientVersion = ver+ , hstClientRandom = crand+ , hstServerRandom = Nothing+ , hstMainSecret = Nothing+ , hstKeyState = HandshakeKeyState Nothing Nothing+ , hstServerDHParams = Nothing+ , hstDHPrivate = Nothing+ , hstServerECDHParams = Nothing+ , hstGroupPrivate = []+ , hstTransHashState = TransHashState0+ , hstTransHashStateI = TransHashState0+ , hstHandshakeMessages = []+ , hstCertReqToken = Nothing+ , hstCertReqCBdata = Nothing+ , hstCertReqSigAlgsCert = Nothing+ , hstClientCertSent = False+ , hstCertReqSent = False+ , hstClientCertChain = Nothing+ , hstPendingTxState = Nothing+ , hstPendingRxState = Nothing+ , hstPendingCipher = Nothing+ , hstPendingCompression = nullCompression+ , hstExtendedMainSecret = False+ , hstSupportedGroup = Nothing+ , hstTLS13HandshakeMode = FullHandshake+ , 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) })- where setPK hks = hks { hksRemotePublicKey = Just pk }+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) })- where setKeys hks = hks { hksLocalPublicPrivateKeys = Just keys }+setPublicPrivateKeys keys = modify' (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)})+ where+ setKeys hks = hks{hksLocalPublicPrivateKeys = Just keys} getRemotePublicKey :: HandshakeM PubKey-getRemotePublicKey = fromJust "remote public key" <$> gets (hksRemotePublicKey . hstKeyState)+getRemotePublicKey = fromJust <$> gets (hksRemotePublicKey . hstKeyState) getLocalPublicPrivateKeys :: HandshakeM (PubKey, PrivKey)-getLocalPublicPrivateKeys = fromJust "local public/private key" <$> gets (hksLocalPublicPrivateKeys . hstKeyState)+getLocalPublicPrivateKeys =+ 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 "server DH params" <$> gets hstServerDHParams+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 "server ECDH params" <$> gets hstServerECDHParams+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 "server DH private" <$> gets hstDHPrivate+getDHPrivate = fromJust <$> gets hstDHPrivate -getGroupPrivate :: HandshakeM GroupPrivate-getGroupPrivate = fromJust "server ECDH private" <$> 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}) -setExtendedMasterSec :: Bool -> HandshakeM ()-setExtendedMasterSec b = modify (\hst -> hst { hstExtendedMasterSec = b })+setExtendedMainSecret :: Bool -> HandshakeM ()+setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b}) -getExtendedMasterSec :: HandshakeM Bool-getExtendedMasterSec = gets hstExtendedMasterSec+getExtendedMainSecret :: HandshakeM Bool+getExtendedMainSecret = gets hstExtendedMainSecret -setNegotiatedGroup :: Group -> HandshakeM ()-setNegotiatedGroup g = modify (\hst -> hst { hstNegotiatedGroup = Just g })+setSupportedGroup :: Group -> HandshakeM ()+setSupportedGroup g = modify' (\hst -> hst{hstSupportedGroup = Just g}) -getNegotiatedGroup :: HandshakeM (Maybe Group)-getNegotiatedGroup = gets hstNegotiatedGroup+getSupportedGroup :: HandshakeM (Maybe Group)+getSupportedGroup = gets hstSupportedGroup -- | Type to show which handshake mode is used in TLS 1.3.-data HandshakeMode13 =- -- | Full handshake is used.+data HandshakeMode13+ = -- | Full handshake is used. FullHandshake- -- | Full handshake is used with hello retry request.- | HelloRetryRequest- -- | Server authentication is skipped.- | PreSharedKey- -- | Server authentication is skipped and early data is sent.- | RTT0- deriving (Show,Eq)+ | -- | Full handshake is used with hello retry request.+ HelloRetryRequest+ | -- | Server authentication is skipped.+ PreSharedKey+ | -- | Server authentication is skipped and early data is sent.+ RTT0+ 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 -data RTT0Status = RTT0None- | RTT0Sent- | RTT0Accepted- | RTT0Rejected- deriving (Show,Eq)+data RTT0Status+ = RTT0None+ | RTT0Sent+ | RTT0Accepted+ | RTT0Rejected+ 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 -- getPendingCipher :: HandshakeM Cipher-getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher+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]- }+-- | Generate the main secret from the pre-main secret.+setMainSecretFromPre+ :: Version+ -- ^ chosen transmission version+ -> Role+ -- ^ the role (Client or Server) of the generating side+ -> Secret+ -- ^ the pre-main secret+ -> HandshakeM Secret+setMainSecretFromPre ver role preMainSecret = do+ ems <- getExtendedMainSecret+ secret <- if ems then get >>= genExtendedSecret else genSecret <$> get+ setMainSecret ver role secret+ return secret+ where+ genSecret hst =+ generateMainSecret+ ver+ (fromJust $ hstPendingCipher hst)+ preMainSecret+ (hstClientRandom hst)+ (fromJust $ hstServerRandom hst)+ genExtendedSecret hst =+ generateExtendedMainSecret+ ver+ (fromJust $ hstPendingCipher hst)+ preMainSecret+ <$> getSessionHash 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 "master secret" $ hstMasterSecret hst- cipher = fromJust "cipher" $ hstPendingCipher hst- in generateFinish ver cipher msecret hashCtx- HandshakeMessages _ ->- error "un-initialized handshake digest"- generateFinish | role == ClientRole = generateClientFinished- | otherwise = generateServerFinished---- | Generate the master secret from the pre master secret.-setMasterSecretFromPre :: ByteArrayAccess preMaster- => Version -- ^ chosen transmission version- -> Role -- ^ the role (Client or Server) of the generating side- -> preMaster -- ^ the pre master secret- -> HandshakeM ByteString-setMasterSecretFromPre ver role premasterSecret = do- ems <- getExtendedMasterSec- secret <- if ems then get >>= genExtendedSecret else genSecret <$> get- setMasterSecret ver role secret- return secret- where genSecret hst =- generateMasterSecret ver (fromJust "cipher" $ hstPendingCipher hst)- premasterSecret- (hstClientRandom hst)- (fromJust "server random" $ hstServerRandom hst)- genExtendedSecret hst =- generateExtendedMasterSec ver (fromJust "cipher" $ hstPendingCipher hst)- premasterSecret- <$> getSessionHash+ case hstTransHashState hst of+ TransHashState2 hashCtx -> hashFinal hashCtx+ _ -> error "un-initialized session hash" --- | Set master secret and as a side effect generate the key block+-- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state.-setMasterSecret :: Version -> Role -> ByteString -> HandshakeM ()-setMasterSecret ver role masterSecret = modify $ \hst ->- let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role- in hst { hstMasterSecret = Just masterSecret+setMainSecret :: Version -> Role -> Secret -> HandshakeM ()+setMainSecret ver role mainSecret = modify' $ \hst ->+ let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role+ in hst+ { hstMainSecret = Just mainSecret , hstPendingTxState = Just pendingTx- , hstPendingRxState = Just pendingRx }--computeKeyBlock :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState)-computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx)- where cipher = fromJust "cipher" $ hstPendingCipher hst- keyblockSize = cipherKeyBlockSize cipher-- bulk = cipherBulk cipher- digestSize = if hasMAC (bulkF bulk) then hashDigestSize (cipherHash cipher)- else 0- keySize = bulkKeySize bulk- ivSize = bulkIVSize bulk- kb = generateKeyBlock ver cipher (hstClientRandom hst)- (fromJust "server random" $ hstServerRandom hst)- masterSecret keyblockSize-- (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =- fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize)+ , hstPendingRxState = Just pendingRx+ } - cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey- , cstIV = cWriteIV- , cstMacSecret = cMACSecret }- cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey- , cstIV = sWriteIV- , cstMacSecret = sMACSecret }- msClient = MacState { msSequence = 0 }- msServer = MacState { msSequence = 0 }+computeKeyBlock+ :: HandshakeState -> Secret -> Version -> Role -> (RecordState, RecordState)+computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx)+ where+ cipher = fromJust $ hstPendingCipher hst+ keyblockSize = cipherKeyBlockSize cipher - pendingTx = RecordState- { stCryptState = if cc == ClientRole then cstClient else cstServer- , stMacState = if cc == ClientRole then msClient else msServer- , stCryptLevel = CryptMasterSecret- , stCipher = Just cipher- , stCompression = hstPendingCompression hst- }- pendingRx = RecordState- { stCryptState = if cc == ClientRole then cstServer else cstClient- , stMacState = if cc == ClientRole then msServer else msClient- , stCryptLevel = CryptMasterSecret- , stCipher = Just cipher- , stCompression = hstPendingCompression hst- }+ bulk = cipherBulk cipher+ digestSize =+ if hasMAC (bulkF bulk)+ then hashDigestSize (cipherHash cipher)+ else 0+ keySize = bulkKeySize bulk+ ivSize = bulkIVSize bulk+ kb =+ generateKeyBlock+ ver+ cipher+ (hstClientRandom hst)+ (fromJust $ hstServerRandom hst)+ mainSecret+ keyblockSize - orOnServer f g = if cc == ClientRole then f else g+ (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =+ fromJust $+ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) + cstClient =+ CryptState+ { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey+ , cstIV = convert $ cWriteIV+ , cstMacSecret = cMACSecret+ }+ cstServer =+ CryptState+ { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey+ , cstIV = convert $ sWriteIV+ , cstMacSecret = sMACSecret+ }+ msClient = MacState{msSequence = 0}+ msServer = MacState{msSequence = 0} -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"+ pendingTx =+ RecordState+ { stCryptState = if cc == ClientRole then cstClient else cstServer+ , stMacState = if cc == ClientRole then msClient else msServer+ , stCryptLevel = CryptMainSecret+ , stCipher = Just cipher+ , stCompression = hstPendingCompression hst+ }+ pendingRx =+ RecordState+ { stCryptState = if cc == ClientRole then cstServer else cstClient+ , stMacState = if cc == ClientRole then msServer else msClient+ , stCryptLevel = CryptMainSecret+ , stCipher = Just cipher+ , stCompression = hstPendingCompression hst+ } --- 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+ orOnServer f g = if cc == ClientRole then f else g
Network/TLS/Handshake/State13.hs view
@@ -1,67 +1,72 @@ {-# LANGUAGE OverloadedStrings #-} --- |--- Module : Network.TLS.Handshake.State13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Handshake.State13- ( CryptLevel ( CryptEarlySecret- , CryptHandshakeSecret- , CryptApplicationSecret- )- , TrafficSecret- , getTxState- , getRxState- , setTxState- , setRxState- , clearTxState- , clearRxState- , setHelloParameters13- , transcriptHash- , wrapAsMessageHash13- , PendingAction(..)- , setPendingActions- , popPendingAction- ) where+module Network.TLS.Handshake.State13 (+ CryptLevel (+ CryptEarlySecret,+ CryptHandshakeSecret,+ CryptApplicationSecret+ ),+ TrafficSecret,+ getTxRecordState,+ getRxRecordState,+ setTxRecordState,+ setRxRecordState,+ getTxLevel,+ getRxLevel,+ clearTxRecordState,+ clearRxRecordState,+ 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.Imports import Network.TLS.Types-import Network.TLS.Util -getTxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)-getTxState ctx = getXState ctx ctxTxState+getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret)+getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)-getRxState ctx = getXState ctx ctxRxState+getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret)+getRxRecordState ctx = getXState ctx ctxRxRecordState -getXState :: Context- -> (Context -> MVar RecordState)- -> IO (Hash, Cipher, CryptLevel, ByteString)+getXState+ :: Context+ -> (Context -> MVar RecordState)+ -> IO (Hash, Cipher, CryptLevel, Secret) getXState ctx func = do tx <- readMVar (func ctx)- let Just usedCipher = stCipher tx+ let usedCipher = fromJust $ stCipher tx usedHash = cipherHash usedCipher level = stCryptLevel tx secret = cstMacSecret $ stCryptState tx return (usedHash, usedCipher, level, secret) +-- In the case of QUIC, stCipher is Nothing.+-- So, fromJust causes an error.+getTxLevel :: Context -> IO CryptLevel+getTxLevel ctx = getXLevel ctx ctxTxRecordState++getRxLevel :: Context -> IO CryptLevel+getRxLevel ctx = getXLevel ctx ctxRxRecordState++getXLevel+ :: Context+ -> (Context -> MVar RecordState)+ -> IO CryptLevel+getXLevel ctx func = do+ tx <- readMVar (func ctx)+ 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)@@ -72,100 +77,74 @@ instance HasCryptLevel a => TrafficSecret (ServerTrafficSecret a) where fromTrafficSecret prx@(ServerTrafficSecret s) = (getCryptLevel prx, s) -setTxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO ()-setTxState = setXState ctxTxState BulkEncrypt+setTxRecordState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO ()+setTxRecordState = setXState ctxTxRecordState BulkEncrypt -setRxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO ()-setRxState = setXState ctxRxState BulkDecrypt+setRxRecordState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO ()+setRxRecordState = setXState ctxRxRecordState BulkDecrypt -setXState :: TrafficSecret ty- => (Context -> MVar RecordState) -> BulkDirection- -> Context -> Hash -> Cipher -> ty- -> IO ()+setXState+ :: TrafficSecret ty+ => (Context -> MVar RecordState)+ -> BulkDirection+ -> Context+ -> Hash+ -> Cipher+ -> ty+ -> IO () setXState func encOrDec ctx h cipher ts = let (lvl, secret) = fromTrafficSecret ts in setXState' func encOrDec ctx h cipher lvl secret -setXState' :: (Context -> MVar RecordState) -> BulkDirection- -> Context -> Hash -> Cipher -> CryptLevel -> ByteString- -> IO ()+setXState'+ :: (Context -> MVar RecordState)+ -> BulkDirection+ -> Context+ -> Hash+ -> Cipher+ -> CryptLevel+ -> Secret+ -> IO () setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt) where- bulk = cipherBulk cipher+ bulk = cipherBulk cipher keySize = bulkKeySize bulk- ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk)+ ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) key = hkdfExpandLabel h secret "key" "" keySize- iv = hkdfExpandLabel h secret "iv" "" ivSize- cst = CryptState {- cstKey = bulkInit bulk encOrDec key- , cstIV = iv- , cstMacSecret = secret- }- rt = RecordState {- stCryptState = cst- , stMacState = MacState { msSequence = 0 }- , stCryptLevel = lvl- , stCipher = Just cipher- , stCompression = nullCompression- }+ iv = hkdfExpandLabel h secret "iv" "" ivSize+ cst =+ CryptState+ { cstKey = bulkInit bulk encOrDec key+ , cstIV = iv+ , cstMacSecret = secret+ }+ rt =+ RecordState+ { stCryptState = cst+ , stMacState = MacState{msSequence = 0}+ , stCryptLevel = lvl+ , stCipher = Just cipher+ , stCompression = nullCompression+ } -clearTxState :: Context -> IO ()-clearTxState = clearXState ctxTxState+clearTxRecordState :: Context -> IO ()+clearTxRecordState = clearXState ctxTxRecordState -clearRxState :: Context -> IO ()-clearRxState = clearXState ctxRxState+clearRxRecordState :: Context -> IO ()+clearRxRecordState = clearXState ctxRxRecordState 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", True, 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 "HState" <$> getHState ctx- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized handshake digest"+ modifyMVar_ (func ctx) (\rt -> return rt{stCipher = Nothing}) -setPendingActions :: Context -> [PendingAction] -> IO ()-setPendingActions ctx = writeIORef (ctxPendingActions ctx)+setPendingRecvActions :: Context -> [PendingRecvAction] -> IO ()+setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx) -popPendingAction :: Context -> IO (Maybe PendingAction)-popPendingAction ctx = do- let ref = ctxPendingActions ctx+popPendingRecvAction :: Context -> IO (Maybe PendingRecvAction)+popPendingRecvAction ctx = do+ let ref = ctxPendingRecvActions ctx actions <- readIORef ref case actions of- bs:bss -> writeIORef ref bss >> return (Just bs)- [] -> return Nothing+ bs : bss -> writeIORef ref bss >> return (Just bs)+ [] -> return Nothing
+ 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,21 +1,16 @@--- |--- Module : Network.TLS.Context--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Hooks- ( Logging(..)- , Hooks(..)- , defaultHooks- ) where+module Network.TLS.Hooks (+ Logging (..),+ defaultLogging,+ Hooks (..),+ defaultHooks,+) where -import qualified Data.ByteString as B-import Network.TLS.Struct (Header, Handshake)+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)-import Data.Default.Class -- | Hooks for logging --@@ -23,40 +18,42 @@ 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-defaultLogging = Logging- { loggingPacketSent = \_ -> return ()- , loggingPacketRecv = \_ -> return ()- , loggingIOSent = \_ -> return ()- , loggingIORecv = \_ _ -> return ()- }+defaultLogging =+ Logging+ { loggingPacketSent = \_ -> return ()+ , loggingPacketRecv = \_ -> return ()+ , loggingIOSent = \_ -> return ()+ , loggingIORecv = \_ _ -> return ()+ } instance Default Logging where def = defaultLogging -- | A collection of hooks actions. data Hooks = Hooks- { -- | called at each handshake message received- hookRecvHandshake :: Handshake -> IO Handshake- -- | called at each handshake message received for TLS 1.3- , hookRecvHandshake13 :: Handshake13 -> IO Handshake13- -- | called at each certificate chain message received+ { hookRecvHandshake :: Handshake -> IO Handshake+ -- ^ called at each handshake message received+ , hookRecvHandshake13 :: Handshake13 -> IO Handshake13+ -- ^ called at each handshake message received for TLS 1.3 , hookRecvCertificates :: CertificateChain -> IO ()- -- | hooks on IO and packets, receiving and sending.- , hookLogging :: Logging+ -- ^ called at each certificate chain message received+ , hookLogging :: Logging+ -- ^ hooks on IO and packets, receiving and sending. } defaultHooks :: Hooks-defaultHooks = Hooks- { hookRecvHandshake = return- , hookRecvHandshake13 = return- , hookRecvCertificates = return . const ()- , hookLogging = def- }+defaultHooks =+ Hooks+ { hookRecvHandshake = return+ , hookRecvHandshake13 = return+ , hookRecvCertificates = return . const ()+ , hookLogging = def+ } instance Default Hooks where def = defaultHooks
Network/TLS/IO.hs view
@@ -1,40 +1,34 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}--- |--- Module : Network.TLS.IO--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.IO- ( sendPacket- , sendPacket13- , recvPacket- , recvPacket13++module Network.TLS.IO (+ sendPacket12,+ sendPacket13,+ recvPacket12,+ recvPacket13, --- , isRecvComplete- , checkValid+ isRecvComplete,+ checkValid,+ -- * Grouping multiple packets in the same flight- , PacketFlightM- , runPacketFlight- , loadPacket13- ) where+ PacketFlightM,+ runPacketFlight,+ loadPacket13,+) where import Control.Exception (finally, throwIO) import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as B import Data.IORef-import System.IO.Error (mkIOError, eofErrorType) 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.Record.Layer-import Network.TLS.Sending import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -42,137 +36,176 @@ ---------------------------------------------------------------- -- | Send one packet to the context-sendPacket :: Context -> Packet -> IO ()-sendPacket 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.+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. when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $- writePacketBytes ctx recordLayer (AppData B.empty) >>=- recordSendBytes recordLayer+ writePacketBytes12 ctx recordLayer (AppData B.empty)+ >>= recordSendBytes recordLayer ctx - writePacketBytes ctx recordLayer pkt >>= recordSendBytes recordLayer- where isNonNullAppData (AppData b) = not $ B.null b- isNonNullAppData _ = False+ writePacketBytes12 ctx recordLayer pkt >>= recordSendBytes recordLayer ctx+ where+ isNonNullAppData (AppData b) = not $ B.null b+ isNonNullAppData _ = False -writePacketBytes :: Monoid bytes- => Context -> RecordLayer bytes -> Packet -> IO bytes-writePacketBytes ctx recordLayer pkt = do+writePacketBytes12+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet+ -> IO bytes+writePacketBytes12 ctx recordLayer pkt = do withLog ctx $ \logging -> loggingPacketSent logging (show pkt)- edataToSend <- encodePacket ctx recordLayer pkt+ edataToSend <- encodePacket12 ctx recordLayer pkt either throwCore return edataToSend ---------------------------------------------------------------- sendPacket13 :: Context -> Packet13 -> IO () sendPacket13 ctx@Context{ctxRecordLayer = recordLayer} pkt =- writePacketBytes13 ctx recordLayer pkt >>= recordSendBytes recordLayer+ writePacketBytes13 ctx recordLayer pkt >>= recordSendBytes recordLayer ctx -writePacketBytes13 :: Monoid bytes- => Context -> RecordLayer bytes -> Packet13 -> IO bytes+writePacketBytes13+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet13+ -> IO bytes writePacketBytes13 ctx recordLayer pkt = do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) edataToSend <- encodePacket13 ctx recordLayer pkt either throwCore return edataToSend ----------------------------------------------------------------+ -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed-recvPacket :: Context -> IO (Either TLSError Packet)-recvPacket ctx@Context{ctxRecordLayer = recordLayer} = do- compatSSLv2 <- ctxHasSSLv2ClientHello ctx- 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 compatSSLv2 appDataOverhead- case erecord of- Left err -> return $ Left err- Right record ->- if hrr && isCCS record then- recvPacket ctx- else do- pktRecv <- processPacket ctx record- if isEmptyHandshake pktRecv then- -- When a handshake record is fragmented we continue- -- receiving in order to feed stHandshakeRecordCont- recvPacket 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 ()- when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx- return pkt+recvPacket12 :: Context -> IO (Either TLSError Packet)+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+ | hrr && isCCS record -> loop (count + 1)+ | otherwise -> do+ pktRecv <- decodePacket12 ctx record+ if isEmptyHandshake pktRecv+ 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+isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool-isEmptyHandshake (Right (Handshake [])) = True-isEmptyHandshake _ = False+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- case erecord of- Left err@(Error_Protocol (_, True, 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 -> 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 _ = False+isEmptyHandshake13 (Right (Handshake13 [] _)) = True+isEmptyHandshake13 _ = False ---------------------------------------------------------------- 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 eofed <- ctxEOF ctx- when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing+ when eofed $ throwIO $ PostHandshake Error_EOF ---------------------------------------------------------------- @@ -183,23 +216,25 @@ -- immediately, update the context digest and transcript, but actual sending is -- deferred. Packets are sent all at once when the monadic computation ends -- (normal termination but also if interrupted by an exception).-newtype PacketFlightM b a = PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO a)+newtype PacketFlightM b a+ = PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO a) deriving (Functor, Applicative, Monad, MonadFail, MonadIO) -runPacketFlight :: Context -> (forall b . Monoid b => PacketFlightM b a) -> IO a-runPacketFlight Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do+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 recordLayer ref+ runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref -sendPendingFlight :: Monoid b => RecordLayer b -> IORef (Builder b) -> IO ()-sendPendingFlight recordLayer ref = do+sendPendingFlight+ :: Monoid b => Context -> RecordLayer b -> IORef (Builder b) -> IO ()+sendPendingFlight ctx recordLayer ref = do build <- readIORef ref let bss = build []- unless (null bss) $ recordSendBytes recordLayer $ mconcat bss+ unless (null bss) $ recordSendBytes recordLayer ctx $ mconcat bss loadPacket13 :: Monoid b => Context -> Packet13 -> PacketFlightM b () loadPacket13 ctx pkt = PacketFlightM $ do (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,109 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.IO.Decode (+ decodePacket12,+ decodePacket13,+) 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.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 decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left err -> return $ Left err+ Right _ -> do+ switchRxEncryption ctx+ return $ Right ChangeCipherSpec+decodePacket12 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, wirebytes) <- gets stHandshakeRecordCont12+ modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])})+ (hss, bss) <-+ unzip <$> parseMany currentParams mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake hss bss+ where+ parseMany currentParams mCont wirebytes bs =+ case fromMaybe decodeHandshakeRecord mCont bs of+ GotError err -> throwError err+ GotPartial cont -> do+ modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)})+ return []+ GotSuccess (ty, content) ->+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))]+ GotSuccessRemaining (ty, content) left ->+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right h -> do+ hbs <- parseMany currentParams Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")++switchRxEncryption :: Context -> IO ()+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 decodeChangeCipherSpec $ fragmentGetBytes 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 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
+ 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
@@ -1,60 +1,34 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} --- |--- Module : Network.TLS.Imports--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Imports- (+module Network.TLS.Imports ( -- generic exports- ByteString- , (<&>)- , module Control.Applicative- , module Control.Monad-#if !MIN_VERSION_base(4,13,0)- , MonadFail-#endif- , module Data.Bits- , module Data.List- , module Data.Maybe- , module Data.Semigroup- , module Data.Ord- , module Data.Word+ ByteString,+ (<&>),+ module Control.Applicative,+ module Control.Monad,+ module Data.Bits,+ module Data.List,+ module Data.Maybe,+ module Data.Semigroup,+ module Data.Ord,+ module Data.Word, -- project definition- , showBytesHex- ) where--import Data.ByteString (ByteString)-import Data.ByteString.Char8 () -- instance-#if MIN_VERSION_base(4,11,0)-import Data.Functor-#endif+ showBytesHex,+) where import Control.Applicative import Control.Monad-#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail (MonadFail)-#endif 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 hiding (fromJust)-import Data.Semigroup+import Data.Maybe import Data.Ord+import Data.Semigroup import Data.Word--import Data.ByteArray.Encoding as B import qualified Prelude as P -#if !MIN_VERSION_base(4,11,0)-(<&>) :: Functor f => f a -> (a -> b) -> f b-(<&>) = P.flip fmap-infixl 1 <&>-#endif- showBytesHex :: ByteString -> P.String showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString)-
Network/TLS/Internal.hs view
@@ -1,28 +1,37 @@ {-# OPTIONS_HADDOCK hide #-}--- |--- Module : Network.TLS.Internal--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Internal- ( module Network.TLS.Struct- , module Network.TLS.Struct13- , module Network.TLS.Packet- , module Network.TLS.Packet13- , module Network.TLS.Receiving- , module Network.TLS.Sending- , module Network.TLS.Wire- , sendPacket- , recvPacket- ) where -import Network.TLS.Struct-import Network.TLS.Struct13+module Network.TLS.Internal (+ 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.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.Core (sendPacket, recvPacket)+import Network.TLS.X509 hiding (Certificate)++----------------------------------------------------------------++makeCipherShowPretty :: IO ()+makeCipherShowPretty = writeIORef globalCipherDict ciphersuite_all
Network/TLS/KeySchedule.hs view
@@ -1,40 +1,37 @@ {-# LANGUAGE OverloadedStrings #-}--- |--- Module : Network.TLS.KeySchedule--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.KeySchedule- ( hkdfExtract- , hkdfExpandLabel- , deriveSecret- ) where +module Network.TLS.KeySchedule (+ hkdfExtract,+ hkdfExpandLabel,+ deriveSecret,+) where+ 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.Wire 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 SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1)+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) hkdfExtract SHA512 salt ikm = convert (extract salt ikm :: PRK H.SHA512)-hkdfExtract _ _ _ = error "hkdfExtract: unsupported hash"+hkdfExtract _ _ _ = error "hkdfExtract: unsupported hash" ---------------------------------------------------------------- -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@@ -43,12 +40,14 @@ -- | @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- -> ByteString- -> ByteString- -> Int- -> ByteString+hkdfExpandLabel+ :: (ByteArray ba, ByteArrayAccess ba)+ => Hash+ -> Secret+ -> ByteString+ -> ByteString+ -> Int+ -> ba hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do@@ -56,8 +55,9 @@ putOpaque8 ("tls13 " `BS.append` label) putOpaque8 ctx -expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString-expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len+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 expand' SHA512 secret label len = expand (extractSkip secret :: PRK H.SHA512) label len
Network/TLS/MAC.hs view
@@ -1,81 +1,83 @@--- |--- Module : Network.TLS.MAC--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.MAC- ( macSSL- , hmac- , prf_MD5- , prf_SHA1- , prf_SHA256- , prf_TLS- , prf_MD5SHA1- ) where+module Network.TLS.MAC (+ macSSL,+ hmac,+ prf_MD5,+ prf_SHA1,+ prf_SHA256,+ prf_TLS,+ prf_MD5SHA1,+ PRF,+) where +import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as BA+ import Network.TLS.Crypto-import Network.TLS.Types import Network.TLS.Imports-import qualified Data.ByteArray as B (xor)-import qualified Data.ByteString as B+import Network.TLS.Types -type HMAC = ByteString -> ByteString -> ByteString+type HMAC = Secret -> ByteString -> Secret macSSL :: Hash -> HMAC macSSL alg secret msg =- f $! B.concat- [ secret- , B.replicate padLen 0x5c- , f $! B.concat [ secret, B.replicate padLen 0x36, msg ]- ]+ f $+ BA.concat+ [ secret+ , BA.replicate padLen 0x5c+ , f $ BA.concat [secret, BA.replicate padLen 0x36, BA.convert msg]+ ] where padLen = case alg of- MD5 -> 48+ MD5 -> 48 SHA1 -> 40- _ -> error ("internal error: macSSL called with " ++ show alg)+ _ -> 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)- where opad = B.map (xor 0x5c) k'- ipad = B.map (xor 0x36) k'+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 = BA.map (0x5c `xor`) k'+ ipad = BA.map (0x36 `xor`) k' - f = hash alg- bl = hashBlockSize alg+ f = hash alg+ bl = hashBlockSize alg - k' = B.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+ k' = BA.append kt pad+ where+ 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]+hmacIter+ :: 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- if digestsize >= len- then [ B.take (fromIntegral len) out ]- else out : hmacIter f secret seed an (len - digestsize)+ let an = f secret aprev+ in let out = f secret (BA.concat [an, BA.convert seed])+ in let digestsize = BA.length out+ in if digestsize >= len+ 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)- where slen = B.length secret- s1 = B.take (slen `div` 2 + slen `mod` 2) secret- s2 = B.drop (slen `div` 2) secret+ BA.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+ where+ 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/Measurement.hs view
@@ -1,46 +1,44 @@--- |--- Module : Network.TLS.Measurement--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Measurement- ( Measurement(..)- , newMeasurement- , addBytesReceived- , addBytesSent- , resetBytesCounters- , incrementNbHandshakes- ) where+module Network.TLS.Measurement (+ Measurement (..),+ newMeasurement,+ addBytesReceived,+ addBytesSent,+ resetBytesCounters,+ incrementNbHandshakes,+) where import Network.TLS.Imports -- | record some data about this connection. data Measurement = Measurement- { nbHandshakes :: !Word32 -- ^ number of handshakes on this context- , bytesReceived :: !Word32 -- ^ bytes received since last handshake- , bytesSent :: !Word32 -- ^ bytes sent since last handshake- } deriving (Show,Eq)+ { nbHandshakes :: Word32+ -- ^ number of handshakes on this context+ , bytesReceived :: Word32+ -- ^ bytes received since last handshake+ , bytesSent :: Word32+ -- ^ bytes sent since last handshake+ }+ deriving (Show, Eq) newMeasurement :: Measurement-newMeasurement = Measurement- { nbHandshakes = 0+newMeasurement =+ Measurement+ { nbHandshakes = 0 , bytesReceived = 0- , bytesSent = 0+ , bytesSent = 0 } addBytesReceived :: Int -> Measurement -> Measurement addBytesReceived sz measure =- measure { bytesReceived = bytesReceived measure + fromIntegral sz }+ measure{bytesReceived = bytesReceived measure + fromIntegral sz} addBytesSent :: Int -> Measurement -> Measurement addBytesSent sz measure =- measure { bytesSent = bytesSent measure + fromIntegral sz }+ measure{bytesSent = bytesSent measure + fromIntegral sz} resetBytesCounters :: Measurement -> Measurement-resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 }+resetBytesCounters measure = measure{bytesReceived = 0, bytesSent = 0} incrementNbHandshakes :: Measurement -> Measurement incrementNbHandshakes measure =- measure { nbHandshakes = nbHandshakes measure + 1 }+ measure{nbHandshakes = nbHandshakes measure + 1}
Network/TLS/Packet.hs view
@@ -1,309 +1,297 @@ {-# LANGUAGE OverloadedStrings #-}--- |--- Module : Network.TLS.Packet--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Packet module contains everything necessary to serialize and deserialize things--- with only explicit parameters, no TLS state is involved here.----module Network.TLS.Packet- (+{-# LANGUAGE RecordWildCards #-}++-- | The Packet module contains everything necessary to serialize and+-- deserialize things with only explicit parameters, no TLS state is+-- involved here.+module Network.TLS.Packet ( -- * params for encoding and decoding- CurrentParams(..)+ CurrentParams (..),+ -- * marshall functions for header messages- , decodeHeader- , decodeDeprecatedHeaderLength- , decodeDeprecatedHeader- , encodeHeader- , encodeHeaderNoVer -- use for SSL3+ decodeHeader,+ encodeHeader, -- * marshall functions for alert messages- , decodeAlert- , decodeAlerts- , encodeAlerts+ decodeAlert,+ decodeAlerts,+ encodeAlerts, -- * marshall functions for handshake messages- , decodeHandshakeRecord- , decodeHandshake- , decodeDeprecatedHandshake- , encodeHandshake- , encodeHandshakeHeader- , encodeHandshakeContent+ decodeHandshakeRecord,+ decodeHandshake,+ encodeHandshake,+ encodeHandshake',+ encodeCertificate,+ decodeClientHello', -- * marshall functions for change cipher spec message- , decodeChangeCipherSpec- , encodeChangeCipherSpec-- , decodePreMasterSecret- , encodePreMasterSecret- , encodeSignedDHParams- , encodeSignedECDHParams-- , decodeReallyServerKeyXchgAlgorithmData+ decodeChangeCipherSpec,+ encodeChangeCipherSpec,+ decodePreMainSecret,+ encodePreMainSecret,+ encodeSignedDHParams,+ encodeSignedECDHParams,+ decodeReallyServerKeyXchgAlgorithmData, -- * generate things for packet content- , generateMasterSecret- , generateExtendedMasterSec- , generateKeyBlock- , generateClientFinished- , generateServerFinished-- , generateCertificateVerify_SSL- , generateCertificateVerify_SSL_DSS+ generateMainSecret,+ generateExtendedMainSecret,+ generateKeyBlock, -- * for extensions parsing- , getSignatureHashAlgorithm- , putSignatureHashAlgorithm- , getBinaryVersion- , putBinaryVersion- , getClientRandom32- , putClientRandom32- , getServerRandom32- , putServerRandom32- , getExtensions- , putExtension- , getSession- , putSession- , putDNames- , getDNames- ) where+ getSignatureHashAlgorithm,+ putSignatureHashAlgorithm,+ getBinaryVersion,+ putBinaryVersion,+ getClientRandom32,+ putClientRandom32,+ getServerRandom32,+ putServerRandom32,+ getExtensions,+ putExtension,+ getSession,+ putSession,+ putDNames,+ getDNames,+ getHandshakeType, -import Network.TLS.Imports-import Network.TLS.Struct-import Network.TLS.Wire-import Network.TLS.Cap-import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain)+ -- * PRF+ PRF,+ getPRF,+) where++import Data.ByteArray (ByteArrayAccess, convert)+import qualified Data.ByteString as B+import Data.X509 (+ CertificateChain,+ CertificateChainRaw (..),+ decodeCertificateChain,+ encodeCertificateChain,+ )+ import Network.TLS.Crypto+import Network.TLS.Imports import Network.TLS.MAC-import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..))+import Network.TLS.Struct+import Network.TLS.Types import Network.TLS.Util.ASN1-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.ByteArray (ByteArrayAccess)-import qualified Data.ByteArray as B (convert)+import Network.TLS.Wire -data CurrentParams = CurrentParams- { cParamsVersion :: Version -- ^ current protocol version- , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type- } deriving (Show,Eq)+----------------------------------------------------------------+-- Header -{- marshall helpers -}-getVersion :: Get Version-getVersion = do- major <- getWord8- minor <- getWord8- case verOfNum (major, minor) of- Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor)- Just v -> return v+data CurrentParams = CurrentParams+ { cParamsVersion :: Version+ -- ^ current protocol version+ , cParamsKeyXchgType :: Maybe CipherKeyExchangeType+ -- ^ current key exchange type+ }+ deriving (Show, Eq) -getBinaryVersion :: Get (Maybe Version)-getBinaryVersion = do- major <- getWord8- minor <- getWord8- return $ verOfNum (major, minor)+-- marshall helpers+getBinaryVersion :: Get Version+getBinaryVersion = Version <$> getWord16 putBinaryVersion :: Version -> Put-putBinaryVersion ver = putWord8 major >> putWord8 minor- where (major, minor) = numericalVer ver+putBinaryVersion (Version ver) = putWord16 ver getHeaderType :: Get ProtocolType-getHeaderType = do- ty <- getWord8- case valToType ty of- Nothing -> fail ("invalid header type: " ++ show ty)- Just t -> return t+getHeaderType = ProtocolType <$> getWord8 putHeaderType :: ProtocolType -> Put-putHeaderType = putWord8 . valOfType+putHeaderType (ProtocolType pt) = putWord8 pt getHandshakeType :: Get HandshakeType-getHandshakeType = do- ty <- getWord8- case valToType ty of- Nothing -> fail ("invalid handshake type: " ++ show ty)- Just t -> return t+getHandshakeType = HandshakeType <$> getWord8 -{-- - decode and encode headers- -}+-- decode and encode headers decodeHeader :: ByteString -> Either TLSError Header-decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getVersion <*> getWord16--decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16-decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16--decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header-decodeDeprecatedHeader size =- runGetErr "deprecatedheader" $ do- 1 <- getWord8- version <- getVersion- return $ Header ProtocolType_DeprecatedHandshake version size+decodeHeader =+ runGetErr "header" $ Header <$> getHeaderType <*> getBinaryVersion <*> getWord16 encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len)- {- FIXME check len <= 2^14 -} -encodeHeaderNoVer :: Header -> ByteString-encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> 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 <- getWord8- ad <- getWord8- case (valToType al, valToType ad) of- (Just a, Just d) -> return (a, d)- (Nothing, _) -> fail "cannot decode alert level"- (_, Nothing) -> fail "cannot decode alert description"+ al <- AlertLevel <$> getWord8+ ad <- AlertDescription <$> getWord8+ return (al, ad) decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)] decodeAlerts = runGetErr "alerts" loop- where loop = do- r <- remaining- if r == 0- then return []- else (:) <$> decodeAlert <*> loop+ where+ loop = do+ r <- remaining+ if r == 0+ then return []+ else (:) <$> decodeAlert <*> loop encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString encodeAlerts l = runPut $ mapM_ encodeAlert l- where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad)+ 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+ ty <- getHandshakeType content <- getOpaque24 return (ty, content) -decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake+{- FOURMOLU_DISABLE -}+decodeHandshake+ :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of- HandshakeType_HelloRequest -> decodeHelloRequest- HandshakeType_ClientHello -> decodeClientHello- HandshakeType_ServerHello -> decodeServerHello- HandshakeType_Certificate -> decodeCertificates- HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp- HandshakeType_CertRequest -> decodeCertRequest cp- HandshakeType_ServerHelloDone -> decodeServerHelloDone- HandshakeType_CertVerify -> decodeCertVerify cp- HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp- HandshakeType_Finished -> decodeFinished--decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake-decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b- where getDeprecated = do- 1 <- getWord8- ver <- getVersion- cipherSpecLen <- fromEnum <$> getWord16- sessionIdLen <- fromEnum <$> getWord16- challengeLen <- fromEnum <$> getWord16- ciphers <- getCipherSpec cipherSpecLen- session <- getSessionId sessionIdLen- random <- getChallenge challengeLen- let compressions = [0]- return $ ClientHello ver random session ciphers compressions [] (Just b)- getCipherSpec len | len < 3 = return []- getCipherSpec len = do- [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8- ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3)- getSessionId 0 = return $ Session Nothing- getSessionId len = Session . Just <$> getBytes len- getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32- getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len+ 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- ver <- getVersion- random <- getClientRandom32- session <- getSession- ciphers <- getWords16+decodeClientHello' :: ByteString -> Either TLSError Handshake+decodeClientHello' = runGetErr "decodeClientHello'" $ decodeClientHello True++decodeClientHello :: Bool -> Get Handshake+decodeClientHello inner = do+ ver <- getBinaryVersion+ random <- getClientRandom32+ session <- getSession+ ciphers <- map CipherId <$> getWords16 compressions <- getWords8- r <- remaining- exts <- if hasHelloExtensions ver && r > 0- then fromIntegral <$> getWord16 >>= getExtensions- else do- rest <- remaining- _ <- getBytes rest- return []- return $ ClientHello ver random session ciphers compressions exts Nothing+ r <- remaining+ exts <-+ if r > 0+ 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 <- getVersion- random <- getServerRandom32- session <- getSession- cipherid <- getWord16+ ver <- getBinaryVersion+ random <- getServerRandom32+ session <- getSession+ cipherid <- CipherId <$> getWord16 compressionid <- getWord8- r <- remaining- exts <- if hasHelloExtensions ver && r > 0- then fromIntegral <$> getWord16 >>= getExtensions+ r <- remaining+ exts <-+ if r > 0+ 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 -decodeCertificates :: Get Handshake-decodeCertificates = do- certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw)+decodeCertificate :: Get Handshake+decodeCertificate = do+ certsRaw <-+ CertificateChainRaw+ <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s)- Right cc -> return $ Certificates cc- where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert)--decodeFinished :: Get Handshake-decodeFinished = Finished <$> (remaining >>= getBytes)--decodeCertRequest :: CurrentParams -> Get Handshake-decodeCertRequest cp = do- mcertTypes <- map (valToType . fromIntegral) <$> getWords8- certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes- sigHashAlgs <- if cParamsVersion cp >= TLS12- then Just <$> (getWord16 >>= getSignatureHashAlgorithms)- else return Nothing- 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+ Right cc -> return $ Certificate $ CertificateChain_ cc 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)+ getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) -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_DSS = 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+ Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke+ Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) +decodeServerKeyXchgAlgorithmData+ :: Version+ -> CipherKeyExchangeType+ -> Get ServerKeyXchgAlgorithmData+decodeServerKeyXchgAlgorithmData ver cke = toCKE+ where+ toCKE = case cke of+ CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA+ CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH+ CipherKeyExchange_DHE_RSA -> do+ dhparams <- getServerDHParams+ signature <- getDigitallySigned ver+ return $ SKX_DHE_RSA dhparams signature+ CipherKeyExchange_DHE_DSA -> do+ dhparams <- getServerDHParams+ signature <- getDigitallySigned ver+ return $ SKX_DHE_DSA dhparams signature+ CipherKeyExchange_ECDHE_RSA -> do+ ecdhparams <- getServerECDHParams+ signature <- getDigitallySigned ver+ return $ SKX_ECDHE_RSA ecdhparams signature+ CipherKeyExchange_ECDHE_ECDSA -> do+ ecdhparams <- getServerECDHParams+ signature <- getDigitallySigned ver+ return $ SKX_ECDHE_ECDSA ecdhparams signature+ _ -> do+ bs <- remaining >>= getBytes+ return $ SKX_Unknown bs+ decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = getServerDHParams @@ -311,123 +299,141 @@ -- decodeServerKeyXchg_ECDH :: Get ServerECDHParams decodeServerKeyXchg_RSA :: Get ServerRSAParams-decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus- <*> getInteger16 -- exponent+decodeServerKeyXchg_RSA =+ ServerRSAParams+ <$> getInteger16 -- modulus+ <*> getInteger16 -- exponent -decodeServerKeyXchgAlgorithmData :: Version- -> CipherKeyExchangeType- -> Get ServerKeyXchgAlgorithmData-decodeServerKeyXchgAlgorithmData ver cke = toCKE- where toCKE = case cke of- CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA- CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH- CipherKeyExchange_DHE_RSA -> do- dhparams <- getServerDHParams- signature <- getDigitallySigned ver- return $ SKX_DHE_RSA dhparams signature- CipherKeyExchange_DHE_DSS -> do- dhparams <- getServerDHParams- signature <- getDigitallySigned ver- return $ SKX_DHE_DSS dhparams signature- CipherKeyExchange_ECDHE_RSA -> do- ecdhparams <- getServerECDHParams- signature <- getDigitallySigned ver- return $ SKX_ECDHE_RSA ecdhparams signature- CipherKeyExchange_ECDHE_ECDSA -> do- ecdhparams <- getServerECDHParams- signature <- getDigitallySigned ver- return $ SKX_ECDHE_ECDSA ecdhparams signature- _ -> do- bs <- remaining >>= getBytes- return $ SKX_Unknown bs+---- -decodeServerKeyXchg :: CurrentParams -> Get Handshake-decodeServerKeyXchg cp =- case cParamsKeyXchgType cp of- Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke- Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes)+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)) -encodeHandshake :: Handshake -> ByteString-encodeHandshake o =- let content = runPut $ encodeHandshakeContent o in- let len = B.length content in- let header = case o of- ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message- _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in- B.concat [ header, content ]+---- -encodeHandshakeHeader :: HandshakeType -> Int -> Put-encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len+decodeServerHelloDone :: Get Handshake+decodeServerHelloDone = return ServerHelloDone -encodeHandshakeContent :: Handshake -> Put+decodeCertVerify :: CurrentParams -> Get Handshake+decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp) -encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do- putBytes deprecated-encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do- putBinaryVersion version- putClientRandom32 random- putSession session- putWords16 cipherIDs- putWords8 compressionIDs- putExtensions exts- return ()+decodeClientKeyXchg :: CurrentParams -> Get Handshake+decodeClientKeyXchg cp =+ -- case ClientKeyXchg <$> (remaining >>= getBytes)+ case cParamsKeyXchgType cp of+ 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"+ parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16+ parseClientECDHPublic = CKX_ECDH <$> getOpaque8 -encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = do- putBinaryVersion version- putServerRandom32 random- putSession session- putWord16 cipherid- putWord8 compressionID- putExtensions exts- return ()+decodeFinished :: Get Handshake+decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes) -encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs)- where (CertificateChainRaw certs) = encodeCertificateChain cc+----------------------------------------------------------------+-- encode HANDSHAKE -encodeHandshakeContent (ClientKeyXchg ckx) = do- case ckx of- CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster- CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic- CKX_ECDH bytes -> putOpaque8 bytes+encodeHandshake :: Handshake -> ByteString+encodeHandshake o =+ let content = encodeHandshake' o+ in let len = B.length content+ in let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len+ in B.concat [header, content] -encodeHandshakeContent (ServerKeyXchg skg) =+encodeHandshakeHeader :: HandshakeType -> Int -> Put+encodeHandshakeHeader ty len = putWord8 (fromHandshakeType ty) >> putWord24 len++encodeHandshake' :: Handshake -> ByteString+encodeHandshake' HelloRequest = ""+encodeHandshake' (ClientHello CH{..}) = runPut $ do+ putBinaryVersion chVersion+ putClientRandom32 chRandom+ putSession chSession+ putWords16 $ map fromCipherId chCiphers+ putWords8 chComps+ putExtensions chExtensions+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 "encodeHandshakeContent SKX_RSA not implemented"- SKX_DH_Anon params -> putServerDHParams params+ SKX_RSA _ -> error "encodeHandshake' SKX_RSA not implemented"+ SKX_DH_Anon params -> putServerDHParams params SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig- SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig+ SKX_DHE_DSA params sig -> putServerDHParams params >> putDigitallySigned sig SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig- SKX_Unparsed bytes -> putBytes bytes- _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg)--encodeHandshakeContent HelloRequest = return ()-encodeHandshakeContent ServerHelloDone = return ()--encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do- putWords8 (map valOfType certTypes)- case sigAlgs of- Nothing -> return ()- Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l+ SKX_Unparsed bytes -> putBytes bytes+ _ -> error ("encodeHandshake': cannot handle: " ++ show skg)+encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do+ putWords8 (map fromCertificateType certTypes)+ putWords16 $+ map+ ( \(HashAlgorithm x, SignatureAlgorithm y) -> fromIntegral x * 256 + fromIntegral y+ )+ sigAlgs putDNames certAuthorities--encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned--encodeHandshakeContent (Finished opaque) = putBytes opaque+encodeHandshake' ServerHelloDone = ""+encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned+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 enc <- mapM encodeCA dnames let totLength = sum $ map ((+) 2 . B.length) enc putWord16 (fromIntegral totLength)- mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc+ mapM_ (\b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc where -- 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@@ -447,119 +453,107 @@ 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+ 0 -> return $ Session Nothing+ 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 Nothing) = putWord8 0 putSession (Session (Just s)) = putOpaque8 s +------------------------------------------------------------+ getExtensions :: Int -> Get [ExtensionRaw]-getExtensions 0 = return []+getExtensions 0 = return [] getExtensions len = do- extty <- getWord16+ extty <- ExtensionID <$> getWord16 extdatalen <- getWord16 extdata <- getBytes $ fromIntegral extdatalen extxs <- getExtensions (len - fromIntegral extdatalen - 4) return $ ExtensionRaw extty extdata : extxs putExtension :: ExtensionRaw -> Put-putExtension (ExtensionRaw ty l) = putWord16 ty >> putOpaque16 l+putExtension (ExtensionRaw (ExtensionID ty) l) = putWord16 ty >> putOpaque16 l putExtensions :: [ExtensionRaw] -> Put putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) +------------------------------------------------------------+ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do- h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm"- s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm"- return (h,s)+ h <- HashAlgorithm <$> getWord8+ s <- SignatureAlgorithm <$> getWord8+ return (h, s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put-putSignatureHashAlgorithm (h,s) =- putWord8 (valOfType h) >> putWord8 (valOfType s)+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]+putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p, g, y] +------------------------------------------------------------+ -- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8 case curveType of- 3 -> do -- ECParameters ECCurveType: curve name type- mgrp <- toEnumSafe16 <$> getWord16 -- ECParameters NamedCurve- case mgrp of- Nothing -> error "getServerECDHParams: unknown group"- Just grp -> do- mxy <- getOpaque8 -- ECPoint- case decodeGroupPublic grp mxy of- Left e -> error $ "getServerECDHParams: " ++ show e- Right grppub -> return $ ServerECDHParams grp grppub- _ ->- error "getServerECDHParams: unknown type for ECDH Params"+ 3 -> do+ -- ECParameters ECCurveType: curve name type+ grp <- Group <$> getWord16 -- ECParameters NamedCurve+ mxy <- getOpaque8 -- ECPoint+ case groupDecodePublicA grp mxy of+ Left e -> fail $ "getServerECDHParams: " ++ show e+ Right grppub -> return $ ServerECDHParams grp grppub+ _ -> fail "getServerECDHParams: unknown type for ECDH Params" -- RFC 4492 Section 5.4 Server Key Exchange putServerECDHParams :: ServerECDHParams -> Put-putServerECDHParams (ServerECDHParams grp grppub) = do- putWord8 3 -- ECParameters ECCurveType- putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve- putOpaque8 $ encodeGroupPublic grppub -- ECPoint+putServerECDHParams (ServerECDHParams (Group grp) grppub) = do+ putWord8 3 -- ECParameters ECCurveType+ putWord16 grp -- ECParameters NamedCurve+ putOpaque8 $ groupEncodePublicA grppub -- ECPoint +------------------------------------------------------------+ getDigitallySigned :: Version -> Get DigitallySigned-getDigitallySigned ver- | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm)- <*> getOpaque16- | otherwise = DigitallySigned Nothing <$> getOpaque16+getDigitallySigned _ver =+ DigitallySigned+ <$> getSignatureHashAlgorithm+ <*> getOpaque16 putDigitallySigned :: DigitallySigned -> Put-putDigitallySigned (DigitallySigned mhash sig) =- maybe (return ()) putSignatureHashAlgorithm mhash >> 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 master secret-decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString)-decodePreMasterSecret = runGetErr "pre-master-secret" $- (,) <$> getVersion <*> getBytes 46+putDigitallySigned (DigitallySigned h sig) =+ putSignatureHashAlgorithm h >> putOpaque16 sig -encodePreMasterSecret :: Version -> ByteString -> ByteString-encodePreMasterSecret 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)+-- RSA pre-main secret+decodePreMainSecret :: ByteString -> Either TLSError (Version, ByteString)+decodePreMainSecret =+ runGetErr "pre-main-secret" $+ (,) <$> getBinaryVersion <*> getBytes 46 +encodePreMainSecret :: Version -> ByteString -> ByteString+encodePreMainSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) -{-- - 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.@@ -569,118 +563,89 @@ | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph -generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString-generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) =- B.concat $ map computeMD5 ["A","BB","CCC"]- where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ]- computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ]--generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> ByteString-generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) =- prf (B.convert premasterSecret) seed 48- where seed = B.concat [ "master secret", c, s ]--generateMasterSecret :: ByteArrayAccess preMaster- => Version- -> Cipher- -> preMaster- -> ClientRandom- -> ServerRandom- -> ByteString-generateMasterSecret SSL2 _ = generateMasterSecret_SSL-generateMasterSecret SSL3 _ = generateMasterSecret_SSL-generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c--generateExtendedMasterSec :: ByteArrayAccess preMaster- => Version- -> Cipher- -> preMaster- -> ByteString- -> ByteString-generateExtendedMasterSec v c premasterSecret sessionHash =- getPRF v c (B.convert premasterSecret) seed 48- where seed = B.append "extended master secret" sessionHash--generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString-generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize =- prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ]--generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString-generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize =- B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels- where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ]- computeMD5 label = hash MD5 $ B.concat [ mastersecret, computeSHA1 label ]- computeSHA1 label = hash SHA1 $ B.concat [ label, mastersecret, s, c ]--generateKeyBlock :: Version- -> Cipher- -> ClientRandom- -> ServerRandom- -> ByteString- -> Int- -> ByteString-generateKeyBlock SSL2 _ = generateKeyBlock_SSL-generateKeyBlock SSL3 _ = generateKeyBlock_SSL-generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c--generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString-generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12- where seed = B.concat [ label, hashFinal hashctx ]--generateFinished_SSL :: ByteString -> ByteString -> HashCtx -> ByteString-generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash]- where md5hash = hash MD5 $ B.concat [ mastersecret, pad2, md5left ]- sha1hash = hash SHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ]-- lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1)- $ foldl hashUpdate hashctx [sender,mastersecret]- (md5left,sha1left) = B.splitAt 16 lefthash- pad2 = B.replicate 48 0x5c- pad1 = B.replicate 48 0x36+generateMainSecret_TLS+ :: PRF+ -> Secret+ -> ClientRandom+ -> ServerRandom+ -> Secret+generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) =+ prf preMainSecret seed 48+ where+ seed = B.concat ["master secret", c, s] -generateClientFinished :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateClientFinished ver ciph- | ver < TLS10 = generateFinished_SSL "CLNT"- | otherwise = generateFinished_TLS (getPRF ver ciph) "client finished"+generateMainSecret+ :: Version+ -> Cipher+ -> Secret+ -> ClientRandom+ -> ServerRandom+ -> Secret+generateMainSecret v c = generateMainSecret_TLS $ getPRF v c -generateServerFinished :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateServerFinished ver ciph- | ver < TLS10 = generateFinished_SSL "SRVR"- | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished"+generateExtendedMainSecret+ :: ByteArrayAccess preMain+ => Version+ -> Cipher+ -> preMain+ -> ByteString+ -> Secret+generateExtendedMainSecret v c preMainSecret sessionHash =+ getPRF v c (convert preMainSecret) seed 48+ where+ seed = B.append "extended master secret" sessionHash -{- returns *output* after final MD5/SHA1 -}-generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString-generateCertificateVerify_SSL = generateFinished_SSL ""+generateKeyBlock_TLS+ :: PRF -> ClientRandom -> ServerRandom -> Secret -> Int -> Secret+generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize =+ prf mainSecret seed kbsize+ where+ seed = B.concat ["key expansion", s, c] -{- returns *input* before final SHA1 -}-generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString-generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash- where toHash = B.concat [ mastersecret, pad2, sha1left ]+generateKeyBlock+ :: Version+ -> Cipher+ -> ClientRandom+ -> ServerRandom+ -> Secret+ -> Int+ -> Secret+generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c - sha1left = hashFinal $ flip hashUpdate pad1- $ hashUpdate hashctx mastersecret- pad2 = B.replicate 40 0x5c- pad1 = B.replicate 40 0x36+------------------------------------------------------------ -encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString-encodeSignedDHParams dhparams cran sran = runPut $- putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams+encodeSignedDHParams+ :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString+encodeSignedDHParams dhparams cran sran =+ runPut $+ putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams -- Combination of RFC 5246 and 4492 is ambiguous. -- Let's assume ecdhe_rsa and ecdhe_dss are identical to -- dhe_rsa and dhe_dss.-encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString-encodeSignedECDHParams dhparams cran sran = runPut $- putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams+encodeSignedECDHParams+ :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString+encodeSignedECDHParams dhparams cran sran =+ runPut $+ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams -fromJustM :: MonadFail m => String -> Maybe a -> m a-fromJustM what Nothing = fail ("fromJustM " ++ what ++ ": Nothing")-fromJustM _ (Just x) = return x+encodeCertificate :: CertificateChain -> ByteString+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,163 +1,176 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} --- |--- Module : Network.TLS.Packet13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Packet13- ( encodeHandshake13- , getHandshakeType13- , decodeHandshakeRecord13- , decodeHandshake13- , decodeHandshakes13- ) where+module Network.TLS.Packet13 (+ encodeHandshake13,+ decodeHandshakeRecord13,+ decodeHandshake13,+ decodeHandshakes13,+ 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 import Network.TLS.Struct import Network.TLS.Struct13-import Network.TLS.Packet+import Network.TLS.Types import Network.TLS.Wire-import Network.TLS.Imports-import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain)-import Network.TLS.ErrT +----------------------------------------------------------------+ encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt where- !tp = typeOfHandshake13 hdsk- !content = encodeHandshake13' hdsk- !len = B.length content- !header = encodeHandshakeHeader13 tp len- !pkt = B.concat [header, content]+ tp = typeOfHandshake13 hdsk+ content = encodeHandshake13' hdsk+ len = B.length content+ header = encodeHandshakeHeader13 tp len+ pkt = B.concat [header, content] -- TLS 1.3 does not use "select (extensions_present)". putExtensions :: [ExtensionRaw] -> Put putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString-encodeHandshake13' (ClientHello13 version random session cipherIDs exts) = runPut $ do- putBinaryVersion version- putClientRandom32 random- putSession session- putWords16 cipherIDs- putWords8 [0]- putExtensions exts-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) = runPut $ do+encodeHandshake13' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do+ putSignatureHashAlgorithm hs+ 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+ putCert (certRaw, exts) = do putOpaque24 certRaw putExtensions exts-encodeHandshake13' (CertVerify13 hs signature) = 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 = ""-encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0-encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1 -encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString-encodeHandshakeHeader13 ty len = runPut $ do- putWord8 (valOfType ty)- putWord24 len+---------------------------------------------------------------- decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of- GotError err -> throwError err- GotPartial _cont -> error "decodeHandshakes13"- GotSuccess (ty,content) -> case decodeHandshake13 ty content of- Left e -> throwError e- Right h -> return [h]- GotSuccessRemaining (ty,content) left -> case decodeHandshake13 ty content of- Left e -> throwError e- Right h -> (h:) <$> decodeHandshakes13 left--{- decode and encode HANDSHAKE -}-getHandshakeType13 :: Get HandshakeType13-getHandshakeType13 = do- ty <- getWord8- case valToType ty of- Nothing -> fail ("invalid handshake type: " ++ show ty)- Just t -> return t+ GotError err -> throwError err+ GotPartial _cont -> error "decodeHandshakes13"+ GotSuccess (ty, content) -> case decodeHandshake13 ty content of+ Left e -> throwError e+ Right h -> return [h]+ GotSuccessRemaining (ty, content) left -> case decodeHandshake13 ty content of+ Left e -> throwError e+ Right h -> (h :) <$> decodeHandshakes13 left -decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType13, ByteString)+decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do- ty <- getHandshakeType13+ ty <- getHandshakeType content <- getOpaque24 return (ty, content) -decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13+{- FOURMOLU_DISABLE -}+decodeHandshake13+ :: HandshakeType -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of- HandshakeType_ClientHello13 -> decodeClientHello13- HandshakeType_ServerHello13 -> decodeServerHello13- HandshakeType_Finished13 -> decodeFinished13- HandshakeType_EncryptedExtensions13 -> decodeEncryptedExtensions13- HandshakeType_CertRequest13 -> decodeCertRequest13- HandshakeType_Certificate13 -> decodeCertificate13- HandshakeType_CertVerify13 -> decodeCertVerify13- HandshakeType_NewSessionTicket13 -> decodeNewSessionTicket13- HandshakeType_EndOfEarlyData13 -> return EndOfEarlyData13- HandshakeType_KeyUpdate13 -> decodeKeyUpdate13--decodeClientHello13 :: Get Handshake13-decodeClientHello13 = do- Just ver <- getBinaryVersion- random <- getClientRandom32- session <- getSession- ciphers <- getWords16- _comp <- getWords8- exts <- fromIntegral <$> getWord16 >>= getExtensions- return $ ClientHello13 ver random session ciphers exts+ 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- Just _ver <- getBinaryVersion- random <- getServerRandom32- session <- getSession- cipherid <- getWord16- _comp <- getWord8- exts <- fromIntegral <$> getWord16 >>= getExtensions- return $ ServerHello13 random session cipherid exts--decodeFinished13 :: Get Handshake13-decodeFinished13 = Finished13 <$> (remaining >>= getBytes)--decodeEncryptedExtensions13 :: Get Handshake13-decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do- len <- fromIntegral <$> getWord16- getExtensions len+ ver <- getBinaryVersion+ random <- getServerRandom32+ session <- getSession+ cipherid <- CipherId <$> getWord16+ comp <- getWord8+ exts <- getWord16 >>= getExtensions . fromIntegral+ return $+ ServerHello13 $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = comp+ , shExtensions = exts+ } -decodeCertRequest13 :: Get Handshake13-decodeCertRequest13 = do- reqctx <- getOpaque8+decodeNewSessionTicket13 :: Get Handshake13+decodeNewSessionTicket13 = do+ life <- getWord32+ ageadd <- getWord32+ nonce <- TicketNonce <$> getOpaque8+ label <- SessionIDorTicket_ <$> getOpaque16 len <- fromIntegral <$> getWord16 exts <- getExtensions len- return $ CertRequest13 reqctx exts+ return $ NewSessionTicket13 life ageadd nonce label exts +decodeEncryptedExtensions13 :: Get Handshake13+decodeEncryptedExtensions13 =+ EncryptedExtensions13 <$> do+ len <- fromIntegral <$> getWord16+ getExtensions len+ decodeCertificate13 :: Get Handshake13 decodeCertificate13 = do reqctx <- getOpaque8@@ -165,7 +178,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@@ -174,18 +187,19 @@ exts <- getExtensions len return (3 + l + 2 + len, (cert, exts)) +decodeCertRequest13 :: Get Handshake13+decodeCertRequest13 = do+ reqctx <- getOpaque8+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ CertRequest13 reqctx exts+ decodeCertVerify13 :: Get Handshake13-decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16+decodeCertVerify13 =+ CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16) -decodeNewSessionTicket13 :: Get Handshake13-decodeNewSessionTicket13 = do- life <- getWord32- ageadd <- getWord32- nonce <- getOpaque8- label <- getOpaque16- len <- fromIntegral <$> getWord16- exts <- getExtensions len- return $ NewSessionTicket13 life ageadd nonce label exts+decodeFinished13 :: Get Handshake13+decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes) decodeKeyUpdate13 :: Get Handshake13 decodeKeyUpdate13 = do@@ -194,3 +208,26 @@ 0 -> return $ KeyUpdate13 UpdateNotRequested 1 -> return $ KeyUpdate13 UpdateRequested x -> fail $ "Unknown request_update: " ++ show x++decodeCompressedCertificate13 :: Get Handshake13+decodeCompressedCertificate13 = do+ algo <- getWord16+ when (algo /= 1) $ fail "comp algo is not supported" -- fixme+ len <- getWord24+ bs <- getOpaque24+ if bs == ""+ then fail "empty compressed certificate"+ else case decompressIt bs of+ Left e -> fail (show e)+ Right bs' -> do+ when (B.length bs' /= len) $ fail "plain length is wrong"+ case runGetMaybe decodeCertificate13 bs' of+ Just (Certificate13 reqctx certs ess) -> return $ CompressedCertificate13 reqctx certs ess+ -- _ -> fail "compressed certificate cannot be parsed"+ _ -> fail $ "invalid compressed certificate: len = " ++ show len++decompressIt :: ByteString -> Either DecompressError ByteString+decompressIt inp = unsafePerformIO $ E.handle handler $ do+ Right . BL.toStrict <$> E.evaluate (decompress (BL.fromStrict inp))+ where+ handler e = return $ Left (e :: DecompressError)
Network/TLS/Parameters.hs view
@@ -1,636 +1,899 @@--- |--- Module : Network.TLS.Parameters--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Parameters- (- ClientParams(..)- , ServerParams(..)- , CommonParams- , DebugParams(..)- , ClientHooks(..)- , OnCertificateRequest- , OnServerCertificate- , ServerHooks(..)- , Supported(..)- , Shared(..)- -- * special default- , defaultParamsClient- -- * Parameters- , MaxFragmentEnum(..)- , EMSMode(..)- , GroupUsage(..)- , CertificateUsage(..)- , CertificateRejectReason(..)- ) where--import Network.TLS.Extension-import Network.TLS.Struct-import qualified Network.TLS.Struct as Struct-import Network.TLS.Session-import Network.TLS.Cipher-import Network.TLS.Measurement-import Network.TLS.Compression-import Network.TLS.Crypto-import Network.TLS.Credentials-import Network.TLS.X509-import Network.TLS.RNG (Seed)-import Network.TLS.Imports-import Network.TLS.Types (HostName)-import Data.Default.Class-import qualified Data.ByteString as B---type CommonParams = (Supported, Shared, DebugParams)---- | All settings should not be used in production-data DebugParams = DebugParams- {- -- | Disable the true randomness in favor of deterministic seed that will produce- -- a deterministic random from. This is useful for tests and debugging purpose.- -- Do not use in production- --- -- Default: 'Nothing'- debugSeed :: Maybe Seed- -- | Add a way to print the seed that was randomly generated. re-using the same seed- -- will reproduce the same randomness with 'debugSeed'- --- -- Default: no printing- , debugPrintSeed :: Seed -> IO ()- -- | Force to choose this version in the server side.- --- -- Default: 'Nothing'- , debugVersionForced :: Maybe Version- -- | Printing master keys.- --- -- Default: no printing- , debugKeyLogger :: String -> IO ()- }--defaultDebugParams :: DebugParams-defaultDebugParams = DebugParams- { debugSeed = Nothing- , debugPrintSeed = const (return ())- , debugVersionForced = Nothing- , debugKeyLogger = \_ -> return ()- }--instance Show DebugParams where- show _ = "DebugParams"-instance Default DebugParams where- def = defaultDebugParams--data ClientParams = ClientParams- { -- |- --- -- Default: 'Nothing'- clientUseMaxFragmentLength :: Maybe MaxFragmentEnum- -- | 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- -- infrastructure.- --- -- This value is typically set by 'defaultParamsClient'.- , clientServerIdentification :: (HostName, ByteString)- -- | 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'- , clientUseServerNameIndication :: Bool- -- | try to establish a connection using this session.- --- -- Default: 'Nothing'- , clientWantSessionResume :: Maybe (SessionID, SessionData)- -- | See the default value of 'Shared'.- , clientShared :: Shared- -- | See the default value of 'ClientHooks'.- , clientHooks :: ClientHooks- -- | 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'.- , clientSupported :: Supported- -- | See the default value of 'DebugParams'.- , clientDebug :: DebugParams- -- | Client tries to send this early data in TLS 1.3 if possible.- -- If not accepted by the server, it is application's responsibility- -- to re-sent it.- --- -- Default: 'Nothing'- , clientEarlyData :: Maybe ByteString- } deriving (Show)--defaultParamsClient :: HostName -> ByteString -> ClientParams-defaultParamsClient serverName serverId = ClientParams- { clientUseMaxFragmentLength = Nothing- , clientServerIdentification = (serverName, serverId)- , clientUseServerNameIndication = True- , clientWantSessionResume = Nothing- , clientShared = def- , clientHooks = def- , clientSupported = def- , clientDebug = defaultDebugParams- , clientEarlyData = Nothing- }--data ServerParams = ServerParams- { -- | Request a certificate from client.- --- -- Default: 'False'- serverWantClientCert :: Bool-- -- | 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: '[]'- , serverCACertificates :: [SignedCertificate]-- -- | 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- -- 'Crypto.PubKey.DH.generateParams'.- --- -- Default: 'Nothing'- , serverDHEParams :: Maybe DHParams- -- | See the default value of 'ServerHooks'.- , serverHooks :: ServerHooks- -- | See the default value of 'Shared'.- , serverShared :: Shared- -- | See the default value of 'Supported'.- , serverSupported :: Supported- -- | See the default value of 'DebugParams'.- , serverDebug :: DebugParams- -- | 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- , serverEarlyDataSize :: Int- -- | Lifetime in seconds for session tickets generated by the server.- -- Acceptable value range is 0 to 604800 (7 days). The default lifetime- -- is 86400 seconds (1 day).- --- -- Default: 86400 (one day)- , serverTicketLifetime :: Int- } deriving (Show)--defaultParamsServer :: ServerParams-defaultParamsServer = ServerParams- { serverWantClientCert = False- , serverCACertificates = []- , serverDHEParams = Nothing- , serverHooks = def- , serverShared = def- , serverSupported = def- , serverDebug = defaultDebugParams- , serverEarlyDataSize = 0- , serverTicketLifetime = 86400- }--instance Default ServerParams where- def = defaultParamsServer---- | List all the supported algorithms, versions, ciphers, etc supported.-data Supported = Supported- {- -- | 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.- --- -- Default: @[TLS13,TLS12,TLS11,TLS10]@- supportedVersions :: [Version]- -- | Supported cipher methods. The default is empty, specify a suitable- -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often- -- a good choice.- --- -- Default: @[]@- , supportedCiphers :: [Cipher]- -- | 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.- --- -- Default: @[nullCompression]@- , supportedCompressions :: [Compression]- -- | All supported hash/signature algorithms pair for client- -- 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'.- --- -- 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, DSS.- --- -- Default:- --- -- @- -- [ (HashIntrinsic, SignatureEd448)- -- , (HashIntrinsic, SignatureEd25519)- -- , (Struct.HashSHA256, SignatureECDSA)- -- , (Struct.HashSHA384, SignatureECDSA)- -- , (Struct.HashSHA512, SignatureECDSA)- -- , (HashIntrinsic, SignatureRSApssRSAeSHA512)- -- , (HashIntrinsic, SignatureRSApssRSAeSHA384)- -- , (HashIntrinsic, SignatureRSApssRSAeSHA256)- -- , (Struct.HashSHA512, SignatureRSA)- -- , (Struct.HashSHA384, SignatureRSA)- -- , (Struct.HashSHA256, SignatureRSA)- -- , (Struct.HashSHA1, SignatureRSA)- -- , (Struct.HashSHA1, SignatureDSS)- -- ]- -- @- , supportedHashSignatures :: [HashAndSignatureAlgorithm]- -- | 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'- , supportedSecureRenegotiation :: 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.- --- -- Default: 'False'- , supportedClientInitiatedRenegotiation :: Bool- -- | The mode regarding extended master secret. Enabling this extension- -- provides better security for TLS versions 1.0 to 1.2. TLS 1.3 provides- -- the security properties natively and does not need the extension.- --- -- By default the extension is enabled but not required. If mode is set- -- to 'RequireEMS', the handshake will fail when the peer does not support- -- the extension. It is also advised to disable SSLv3 which does not have- -- this mechanism.- --- -- Default: 'AllowEMS'- , supportedExtendedMasterSec :: EMSMode- -- | Set if we support session.- --- -- Default: 'True'- , supportedSession :: Bool- -- | Support for fallback SCSV defined in RFC7507.- -- If 'True', servers reject handshakes which suggest- -- a lower protocol than the highest protocol supported.- --- -- Default: 'True'- , supportedFallbackScsv :: 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.- --- -- Default: 'True'- , supportedEmptyPacket :: Bool- -- | A list of supported elliptic curves and finite-field groups in the- -- 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.- --- -- The default value includes all groups with security strength of 128- -- bits or more.- --- -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@- , supportedGroups :: [Group]- } deriving (Show,Eq)---- | Client or server policy regarding Extended Master Secret-data EMSMode- = NoEMS -- ^ Extended Master Secret is not used- | AllowEMS -- ^ Extended Master Secret is allowed- | RequireEMS -- ^ Extended Master Secret is required- deriving (Show,Eq)--defaultSupported :: Supported-defaultSupported = Supported- { supportedVersions = [TLS13,TLS12,TLS11,TLS10]- , supportedCiphers = []- , supportedCompressions = [nullCompression]- , supportedHashSignatures = [ (HashIntrinsic, SignatureEd448)- , (HashIntrinsic, SignatureEd25519)- , (Struct.HashSHA256, SignatureECDSA)- , (Struct.HashSHA384, SignatureECDSA)- , (Struct.HashSHA512, SignatureECDSA)- , (HashIntrinsic, SignatureRSApssRSAeSHA512)- , (HashIntrinsic, SignatureRSApssRSAeSHA384)- , (HashIntrinsic, SignatureRSApssRSAeSHA256)- , (Struct.HashSHA512, SignatureRSA)- , (Struct.HashSHA384, SignatureRSA)- , (Struct.HashSHA256, SignatureRSA)- , (Struct.HashSHA1, SignatureRSA)- , (Struct.HashSHA1, SignatureDSS)- ]- , supportedSecureRenegotiation = True- , supportedClientInitiatedRenegotiation = False- , supportedExtendedMasterSec = AllowEMS- , supportedSession = True- , supportedFallbackScsv = True- , supportedEmptyPacket = True- , supportedGroups = [X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]- }--instance Default Supported where- def = defaultSupported---- | Parameters that are common to clients and servers.-data Shared = Shared- { -- | 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.- --- -- Default: 'mempty'- sharedCredentials :: Credentials- -- | 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.- --- -- Default: 'noSessionManager'- , sharedSessionManager :: SessionManager- -- | 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/x509-system x509-system>- -- gives access to a default certificate store configured in the- -- system.- --- -- Default: 'mempty'- , sharedCAStore :: CertificateStore- -- | 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.- --- -- See the default value of 'ValidationCache'.- , sharedValidationCache :: ValidationCache- -- | 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.- --- -- Default: @[]@- , sharedHelloExtensions :: [ExtensionRaw]- }--instance Show Shared where- show _ = "Shared"-instance Default Shared where- def = Shared- { sharedCredentials = mempty- , sharedSessionManager = noSessionManager- , sharedCAStore = mempty- , sharedValidationCache = def- , sharedHelloExtensions = []- }---- | Group usage callback possible return values.-data GroupUsage =- GroupUsageValid -- ^ usage of group accepted- | GroupUsageInsecure -- ^ usage of group provides insufficient security- | GroupUsageUnsupported String -- ^ usage of group rejected for other reason (specified as string)- | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value- deriving (Show,Eq)--defaultGroupUsage :: Int -> DHParams -> DHPublic -> IO GroupUsage-defaultGroupUsage minBits params public- | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime"- | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator"- | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic- -- To prevent Logjam attack- | dhParamsGetBits params < minBits = return GroupUsageInsecure- | otherwise = return GroupUsageValid---- | Type for 'onCertificateRequest'. This type synonym is to make--- document readable.-type OnCertificateRequest = ([CertificateType],- Maybe [HashAndSignatureAlgorithm],- [DistinguishedName])- -> IO (Maybe (CertificateChain, PrivKey))---- | Type for 'onServerCertificate'. This type synonym is to make--- document readable.-type OnServerCertificate = CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason]---- | A set of callbacks run by the clients for various corners of TLS establishment-data ClientHooks = ClientHooks- { -- | 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.- --- -- 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.- --- -- 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- -- <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.- --- -- 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.- --- -- Default: returns 'Nothing' anyway.- onCertificateRequest :: OnCertificateRequest- -- | 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.- --- -- Default: 'validateDefault'- , onServerCertificate :: OnServerCertificate- -- | This action is called when the client sends ClientHello- -- to determine ALPN values such as '["h2", "http/1.1"]'.- --- -- Default: returns 'Nothing'- , onSuggestALPN :: IO (Maybe [B.ByteString])- -- | 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.- --- -- 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.- , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage- }--defaultClientHooks :: ClientHooks-defaultClientHooks = ClientHooks- { onCertificateRequest = \ _ -> return Nothing- , onServerCertificate = validateDefault- , onSuggestALPN = return Nothing- , onCustomFFDHEGroup = defaultGroupUsage 1024- }--instance Show ClientHooks where- show _ = "ClientHooks"-instance Default ClientHooks where- def = defaultClientHooks---- | A set of callbacks run by the server for various corners of the TLS establishment-data ServerHooks = ServerHooks- {- -- | 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.- --- -- Default: returns the followings:- --- -- @- -- CertificateUsageReject (CertificateRejectOther "no client certificates expected")- -- @- onClientCertificate :: CertificateChain -> IO CertificateUsage-- -- | 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'- , onUnverifiedClientCert :: IO Bool-- -- | 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)- --- -- The client cipher list cannot be empty.- --- -- Default: taking the head of ciphers.- , onCipherChoosing :: Version -> [Cipher] -> Cipher-- -- | 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.- --- -- Returned credentials may be ignored if a client does not support- -- the signature algorithms used in the certificate chain.- --- -- Default: returns 'mempty'- , onServerNameIndication :: Maybe HostName -> IO Credentials-- -- | At each new handshake, we call this hook to see if we allow handshake to happens.- --- -- Default: returns 'True'- , onNewHandshake :: Measurement -> IO Bool-- -- | 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.- --- -- Default: 'Nothing'- , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)- -- | Allow to modify extensions to be sent in EncryptedExtensions- -- of TLS 1.3.- --- -- Default: 'return . id'- , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]- }--defaultServerHooks :: ServerHooks-defaultServerHooks = ServerHooks- { onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected"- , onUnverifiedClientCert = return False- , onCipherChoosing = \_ -> head- , onServerNameIndication = \_ -> return mempty- , onNewHandshake = \_ -> return True- , onALPNClientSuggest = Nothing- , onEncryptedExtensionsCreating = return . id- }--instance Show ServerHooks where- show _ = "ServerHooks"-instance Default ServerHooks where- def = defaultServerHooks+{-# LANGUAGE Strict #-}++module Network.TLS.Parameters (+ ClientParams (..),+ defaultParamsClient,+ ServerParams (..),+ defaultParamsServer,+ CommonParams,+ DebugParams (..),+ defaultDebugParams,+ defaultKeyLogger,+ ClientHooks (..),+ defaultClientHooks,+ OnCertificateRequest,+ OnServerCertificate,+ ServerHooks (..),+ defaultServerHooks,+ Supported (..),+ defaultSupported,+ Shared (..),+ defaultShared,+ Limit (..),+ defaultLimit,++ -- * Parameters+ MaxFragmentEnum (..),+ EMSMode (..),+ GroupUsage (..),+ CertificateUsage (..),+ CertificateRejectReason (..),+ Information (..),+) where++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)+import Network.TLS.Session+import Network.TLS.Struct+import qualified Network.TLS.Struct as Struct+import Network.TLS.Types (HostName)+import Network.TLS.X509++type CommonParams = (Supported, Shared, DebugParams)++-- | All settings should not be used in production+data DebugParams = DebugParams+ { debugSeed :: Maybe Seed+ -- ^ Disable the true randomness in favor of deterministic seed that will produce+ -- a deterministic random from. This is useful for tests and debugging purpose.+ -- Do not use in production+ --+ -- Default: 'Nothing'+ , debugPrintSeed :: Seed -> IO ()+ -- ^ 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+ , debugVersionForced :: Maybe Version+ -- ^ Force to choose this version in the server side.+ --+ -- Default: 'Nothing'+ , debugKeyLogger :: String -> IO ()+ -- ^ 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 = defaultKeyLogger+ , debugError = \ ~_ -> return ()+ , debugTraceKey = \ ~_ -> return ()+ }++instance Show DebugParams where+ show _ = "DebugParams"+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.+ --+ -- 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+ -- CNAME aliasing (e.g. web virtual host).+ --+ -- Default: 'True'+ , clientWantSessionResume :: Maybe (SessionID, SessionData)+ -- ^ 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.+ --+ -- 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.+ --+ -- 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+ { clientUseMaxFragmentLength = Nothing+ , 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+ { serverWantClientCert :: Bool+ -- ^ Request a certificate from client.+ --+ -- 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.+ --+ -- 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.+ --+ -- Value can be one of the standardized groups from module+ -- "Network.TLS.Extra.FFDHE" or custom parameters generated with+ -- 'Crypto.PubKey.DH.generateParams'.+ --+ -- Default: 'Nothing'+ , serverHooks :: ServerHooks+ -- ^ See the default value of 'ServerHooks'.+ , serverShared :: Shared+ -- ^ See the default value of 'Shared'.+ , serverSupported :: Supported+ -- ^ See the default value of 'Supported'.+ , 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.+ --+ -- Default: 0+ , serverTicketLifetime :: Int+ -- ^ 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)++defaultParamsServer :: ServerParams+defaultParamsServer =+ ServerParams+ { serverWantClientCert = False+ , serverCACertificates = []+ , serverDHEParams = Nothing+ , serverHooks = def+ , serverShared = def+ , serverSupported = def+ , serverDebug = defaultDebugParams+ , serverEarlyDataSize = 0+ , serverTicketLifetime = 7200+ , serverECHKey = []+ }++instance Default ServerParams where+ def = defaultParamsServer++-- | 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- Default: @[nullCompression]@+ , supportedHashSignatures :: [HashAndSignatureAlgorithm]+ -- ^ All supported hash/signature algorithms pair for client+ -- 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'.+ --+ -- 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.+ --+ -- Default:+ --+ -- @+ -- [ (HashIntrinsic, SignatureEd448)+ -- , (HashIntrinsic, SignatureEd25519)+ -- , (Struct.HashSHA256, SignatureECDSA)+ -- , (Struct.HashSHA384, SignatureECDSA)+ -- , (Struct.HashSHA512, SignatureECDSA)+ -- , (HashIntrinsic, SignatureRSApssRSAeSHA512)+ -- , (HashIntrinsic, SignatureRSApssRSAeSHA384)+ -- , (HashIntrinsic, SignatureRSApssRSAeSHA256)+ -- , (Struct.HashSHA512, SignatureRSA)+ -- , (Struct.HashSHA384, SignatureRSA)+ -- , (Struct.HashSHA256, SignatureRSA)+ -- , (Struct.HashSHA1, SignatureRSA)+ -- , (Struct.HashSHA1, SignatureDSA)+ -- ]+ -- @+ , 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.+ --+ -- 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.+ --+ -- 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 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.+ --+ -- 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.+ --+ -- 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 preferred order.+ --+ -- * TLS 1.3 client: this list is used as the 1st argument to+ -- 'onSelectKeyShareGroups' to select groups in "key_share".+ -- This list is also used as values of "supported_groups".+ -- * TLS 1.3 server: this list is not used.+ -- * TLS 1.2 client: this list is also used as values of+ -- "supported_groups".+ -- * TLS 1.2 server: this list is used to select a key exchange+ -- mechanism.+ --+ -- The list is sent to the server as part of the+ -- "supported_groups" extension. It is used in both clients and+ -- servers to restrict accepted groups in DH key exchange. Up+ -- until TLS v1.2, it is also used by a client to restrict+ -- accepted elliptic curves in ECDSA signatures.+ --+ -- 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)++-- | Client or server policy regarding Extended Main Secret+data EMSMode+ = -- | Extended Main Secret is not used+ NoEMS+ | -- | Extended Main Secret is allowed+ AllowEMS+ | -- | Extended Main Secret is required+ 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+ { supportedVersions = [TLS13, TLS12]+ , supportedCiphers = ciphersuite_default+ , supportedCompressions = [nullCompression]+ , supportedHashSignatures = Struct.supportedSignatureSchemes+ , supportedSecureRenegotiation = True+ , supportedClientInitiatedRenegotiation = False+ , supportedExtendedMainSecret = RequireEMS+ , supportedSession = True+ , supportedFallbackScsv = True+ , supportedEmptyPacket = True+ , supportedHPKE = defaultHPKE+ , supportedGroups = supportedNamedGroups+ , supportedGroupsTLS13 = supportedNamedGroupsTLS13+ }++instance Default Supported where+ def = defaultSupported++-- | 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.+ --+ -- When credential list is left empty (the default value), no key+ -- exchange can take place.+ --+ -- 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- 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 = 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+ GroupUsageValid+ | -- | usage of group provides insufficient security+ GroupUsageInsecure+ | -- | usage of group rejected for other reason (specified as string)+ GroupUsageUnsupported String+ | -- | usage of group with an invalid public value+ GroupUsageInvalidPublic+ deriving (Show, Eq)++defaultGroupUsage :: Int -> DHParams -> DHPublic -> IO GroupUsage+defaultGroupUsage minBits params public+ | even $ dhParamsGetP params =+ return $ GroupUsageUnsupported "invalid odd prime"+ | not $ dhValid params (dhParamsGetG params) =+ return $ GroupUsageUnsupported "invalid generator"+ | not $ dhValid params (dhUnwrapPublic public) =+ return GroupUsageInvalidPublic+ -- To prevent Logjam attack+ | dhParamsGetBits params < minBits = return GroupUsageInsecure+ | otherwise = return GroupUsageValid++-- | Type for 'onCertificateRequest'. This type synonym is to make+-- document readable.+type OnCertificateRequest =+ ( [CertificateType]+ , Maybe [HashAndSignatureAlgorithm]+ , [DistinguishedName]+ )+ -> IO (Maybe (CertificateChain, PrivKey))++-- | Type for 'onServerCertificate'. This type synonym is to make+-- document readable.+type OnServerCertificate =+ CertificateStore+ -> ValidationCache+ -> ServiceID+ -> CertificateChain+ -> IO [FailedReason]++-- | A set of callbacks run by the clients for various corners of TLS establishment+data ClientHooks = ClientHooks+ { 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.+ --+ -- 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.+ --+ -- 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+ -- <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.+ --+ -- 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- Default: 'validateDefault'+ , 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.+ --+ -- 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:+ --+ -- (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 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+ { onCertificateRequest = \_ -> return Nothing+ , onServerCertificate = validateDefault+ , onSuggestALPN = return Nothing+ , onCustomFFDHEGroup = defaultGroupUsage 1024+ , onServerFinished = \_ -> return ()+ , onSelectKeyShareGroups = defaultOnSelectKeyShareGroups+ }++instance Show ClientHooks where+ show _ = "ClientHooks"+instance Default ClientHooks where+ def = defaultClientHooks++-- | 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+ -- 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- 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.+ --+ -- Default: returns 'mempty'+ , onNewHandshake :: Measurement -> IO Bool+ -- ^ At each new handshake, we call this hook to see if we allow+ -- handshake to happens.+ --+ -- Default: returns 'True'+ , 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.+ --+ -- Default: 'Nothing'+ , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]+ -- ^ Allow to modify extensions to be sent in EncryptedExtensions+ -- 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+ { onClientCertificate = \_ ->+ return $+ CertificateUsageReject $+ CertificateRejectOther "no client certificates expected"+ , onUnverifiedClientCert = return False+ , 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+ }+ deriving (Eq, Show)++-- | Default value for 'Limit'.+defaultLimit :: Limit+defaultLimit =+ Limit+ { limitRecordSize = Nothing+ , limitHandshakeFragment = 32+ }
Network/TLS/PostHandshake.hs view
@@ -1,39 +1,33 @@--- |--- Module : Network.TLS.PostHandshake--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.PostHandshake- ( requestCertificate- , requestCertificateServer- , postHandshakeAuthWith- , postHandshakeAuthClientWith- , postHandshakeAuthServerWith- ) where+module Network.TLS.PostHandshake (+ requestCertificate,+ requestCertificateServer,+ postHandshakeAuthWith,+ postHandshakeAuthClientWith,+) where import Network.TLS.Context.Internal-import Network.TLS.IO-import Network.TLS.Struct13--import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client+import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.IO+import Network.TLS.Struct13 -import Control.Monad.State.Strict+---------------------------------------------------------------- --- | 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.-requestCertificate :: MonadIO m => Context -> m Bool+-- | 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 =- liftIO $ withWriteLock ctx $- checkValid ctx >> ctxDoRequestCertificate 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 :: MonadIO m => Context -> Handshake13 -> m ()+-- | Handle a post-handshake authentication flight with TLS 1.3. This+-- is called automatically by 'recvData', in a context where the read+-- lock is already taken. Client only.+postHandshakeAuthWith :: Context -> Handshake13 -> IO () postHandshakeAuthWith ctx hs =- liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoPostHandshakeAuthWith ctx ctx hs+ withWriteLock ctx $+ handleException ctx $+ doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs
Network/TLS/QUIC.hs view
@@ -1,12 +1,7 @@ {-# LANGUAGE OverloadedStrings #-}+ -- |--- Module : Network.TLS.QUIC--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Experimental API to run the TLS handshake establishing a QUIC connection.+-- API to run the TLS handshake establishing a QUIC connection. -- -- On the northbound API: --@@ -25,152 +20,150 @@ -- exchanged through the handshake protocol. -- -- * TLS calls 'quicDone' when the handshake is done.--- module Network.TLS.QUIC ( -- * Handshakers- tlsQUICClient- , tlsQUICServer+ tlsQUICClient,+ tlsQUICServer,+ -- * Callback- , QUICCallbacks(..)- , CryptLevel(..)- , KeyScheduleEvent(..)+ QUICCallbacks (..),+ CryptLevel (..),+ KeyScheduleEvent (..),+ -- * Secrets- , EarlySecretInfo(..)- , HandshakeSecretInfo(..)- , ApplicationSecretInfo(..)- , EarlySecret- , HandshakeSecret- , ApplicationSecret- , TrafficSecrets- , ServerTrafficSecret(..)- , ClientTrafficSecret(..)+ EarlySecretInfo (..),+ HandshakeSecretInfo (..),+ ApplicationSecretInfo (..),+ EarlySecret,+ HandshakeSecret,+ ApplicationSecret,+ TrafficSecrets,+ ServerTrafficSecret (..),+ ClientTrafficSecret (..),+ -- * Negotiated parameters- , NegotiatedProtocol- , HandshakeMode13(..)+ NegotiatedProtocol,+ HandshakeMode13 (..),+ -- * Extensions- , ExtensionRaw(..)- , ExtensionID- , extensionID_QuicTransportParameters+ ExtensionRaw (..),+ ExtensionID (ExtensionID, EID_QuicTransportParameters),+ -- * Errors- , errorTLS- , errorToAlertDescription- , errorToAlertMessage- , fromAlertDescription- , toAlertDescription+ errorTLS,+ errorToAlertDescription,+ errorToAlertMessage,+ fromAlertDescription,+ toAlertDescription,+ -- * Hash- , hkdfExpandLabel- , hkdfExtract- , hashDigestSize+ hkdfExpandLabel,+ hkdfExtract,+ hashDigestSize,+ -- * Constants- , quicMaxEarlyDataSize+ quicMaxEarlyDataSize,+ -- * Supported- , defaultSupported- ) where+ 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 (extensionID_QuicTransportParameters)+import Network.TLS.Extension import Network.TLS.Extra.Cipher import Network.TLS.Handshake.Common import Network.TLS.Handshake.Control import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports-import Network.TLS.KeySchedule (hkdfExtract, hkdfExpandLabel)-import Network.TLS.Parameters+import Network.TLS.KeySchedule (hkdfExpandLabel, hkdfExtract)+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 {- backendFlush = return ()- , backendClose = return ()- , backendSend = \_ -> return ()- , backendRecv = \_ -> return ""- }+nullBackend =+ Backend+ { backendFlush = return ()+ , backendClose = return ()+ , backendSend = \_ -> return ()+ , backendRecv = \_ -> return ""+ } -- | Argument given to 'quicInstallKeys' when encryption material is available. data KeyScheduleEvent- = InstallEarlyKeys (Maybe EarlySecretInfo)- -- ^ Key material and parameters for traffic at 0-RTT level- | InstallHandshakeKeys HandshakeSecretInfo- -- ^ Key material and parameters for traffic at handshake level- | InstallApplicationKeys ApplicationSecretInfo- -- ^ Key material and parameters for traffic at application level+ = -- | Key material and parameters for traffic at 0-RTT level+ InstallEarlyKeys (Maybe EarlySecretInfo)+ | -- | Key material and parameters for traffic at handshake level+ InstallHandshakeKeys HandshakeSecretInfo+ | -- | Key material and parameters for traffic at application level+ InstallApplicationKeys ApplicationSecretInfo -- | Callbacks implemented by QUIC and to be called by TLS at specific points -- during the handshake. TLS may invoke them from external threads but calls -- are not concurrent. Only a single callback function is called at a given -- point in time. data QUICCallbacks = QUICCallbacks- { 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- -- given for the specified level and an appropriate encryption scheme.- --- -- The size of the fragments may exceed QUIC datagram limits so QUIC may- -- break them into smaller fragments.- --- -- The handshake protocol sometimes combines content at two levels in a- -- single flight. The TLS library does its best to provide this in the- -- same @quicSend@ call and with a multi-valued argument. QUIC can then- -- decide how to transmit this optimally.- , quicRecv :: CryptLevel -> IO (Either TLSError ByteString)- -- ^ Called by TLS to receive from QUIC the next plaintext handshake- -- fragment. The argument specifies with which encryption level the- -- fragment should be decrypted.- --- -- QUIC may return partial fragments to TLS. TLS will then call- -- @quicRecv@ again as long as necessary. Note however that fragments- -- must be returned in the correct sequence, i.e. the order the TLS peer- -- emitted them.- --- -- The function may return an error to TLS if end of stream is reached or- -- if a protocol error has been received, believing the handshake cannot- -- proceed any longer. If the TLS handshake protocol cannot recover from- -- this error, the failure condition will be reported back to QUIC through- -- the control interface.- , quicInstallKeys :: Context -> KeyScheduleEvent -> IO ()- -- ^ Called by TLS when new encryption material is ready to be used in the- -- handshake. The next 'quicSend' or 'quicRecv' may now use the- -- associated encryption level (although the previous level is also- -- possible: directions Send/Recv do not change at the same time).- , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO ()- -- ^ Called by TLS when QUIC-specific extensions have been received from- -- the peer.+ { 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 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+ -- break them into smaller fragments.+ --+ -- The handshake protocol sometimes combines content at two levels in a+ -- single flight. The TLS library does its best to provide this in the+ -- same @quicSend@ call and with a multi-valued argument. QUIC can then+ -- decide how to transmit this optimally.+ , quicRecv :: CryptLevel -> IO (Either TLSError ByteString)+ -- ^ Called by TLS to receive from QUIC the next plaintext handshake+ -- fragment. The argument specifies with which encryption level the+ -- fragment should be decrypted.+ --+ -- QUIC may return partial fragments to TLS. TLS will then call+ -- @quicRecv@ again as long as necessary. Note however that fragments+ -- must be returned in the correct sequence, i.e. the order the TLS peer+ -- emitted them.+ --+ -- The function may return an error to TLS if end of stream is reached or+ -- if a protocol error has been received, believing the handshake cannot+ -- proceed any longer. If the TLS handshake protocol cannot recover from+ -- this error, the failure condition will be reported back to QUIC through+ -- the control interface.+ , quicInstallKeys :: Context -> KeyScheduleEvent -> IO ()+ -- ^ Called by TLS when new encryption material is ready to be used in the+ -- handshake. The next 'quicSend' or 'quicRecv' may now use the+ -- associated encryption level (although the previous level is also+ -- possible: directions Send/Recv do not change at the same time).+ , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO ()+ -- ^ Called by TLS when QUIC-specific extensions have been received from+ -- the peer. , quicDone :: Context -> IO ()- -- ^ Called when 'handshake' is done. 'tlsQUICServer' is- -- finished after calling this hook. 'tlsQUICClient' calls- -- 'recvData' after calling this hook to wait for new session- -- tickets.+ -- ^ Called when 'handshake' is done. 'tlsQUICServer' is+ -- finished after calling this hook. 'tlsQUICClient' calls+ -- 'recvData' after calling this hook to wait for new session+ -- tickets. } -getTxLevel :: Context -> IO CryptLevel-getTxLevel ctx = do- (_, _, level, _) <- getTxState ctx- return level--getRxLevel :: Context -> IO CryptLevel-getRxLevel ctx = do- (_, _, level, _) <- getRxState ctx- return level--newRecordLayer :: Context -> QUICCallbacks- -> RecordLayer [(CryptLevel, ByteString)]-newRecordLayer ctx callbacks = newTransparentRecordLayer get send recv+newRecordLayer+ :: QUICCallbacks+ -> RecordLayer [(CryptLevel, ByteString)]+newRecordLayer callbacks = newTransparentRecordLayer get send recv where- get = getTxLevel ctx- send = quicSend callbacks- recv = getRxLevel ctx >>= quicRecv callbacks+ get = getTxLevel+ send = quicSend callbacks+ recv ctx = getRxLevel ctx >>= quicRecv callbacks -- | Start a TLS handshake thread for a QUIC client. The client will use the -- specified TLS parameters and call the provided callback functions to send and@@ -178,12 +171,16 @@ tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams- let ctx1 = ctx0- { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ())- , ctxFragmentSize = Nothing- , ctxQUICMode = True- }- rl = newRecordLayer ctx2 callbacks+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing+ let ctx1 =+ ctx0+ { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ())+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref+ , ctxQUICMode = True+ }+ rl = newRecordLayer callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 quicDone callbacks ctx2@@ -196,7 +193,8 @@ sync ctx (SendClientFinished exts appSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do- throwCore $ Error_Protocol ("QUIC transport parameters are mssing", True, MissingExtension)+ throwCore $+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -206,12 +204,16 @@ tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams- let ctx1 = ctx0- { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync- , ctxFragmentSize = Nothing- , ctxQUICMode = True- }- rl = newRecordLayer ctx2 callbacks+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing+ let ctx1 =+ ctx0+ { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref+ , ctxQUICMode = True+ }+ rl = newRecordLayer callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 quicDone callbacks ctx2@@ -219,7 +221,8 @@ sync ctx (SendServerHello exts mEarlySecInfo handSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do- throwCore $ Error_Protocol ("QUIC transport parameters are mssing", True, MissingExtension)+ throwCore $+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)@@ -227,35 +230,35 @@ quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) filterQTP :: [ExtensionRaw] -> [ExtensionRaw]-filterQTP = filter (\(ExtensionRaw eid _) -> eid == extensionID_QuicTransportParameters || eid == 0xffa5) -- to be deleted+filterQTP =+ filter+ (\(ExtensionRaw eid _) -> eid == EID_QuicTransportParameters) -- | Can be used by callbacks to signal an unexpected condition. This will then -- generate an "internal_error" alert in the TLS stack. errorTLS :: String -> IO a-errorTLS msg = throwCore $ Error_Protocol (msg, True, InternalError)+errorTLS msg = throwCore $ Error_Protocol msg InternalError -- | Return the alert that a TLS endpoint would send to the peer for the -- specified library error. errorToAlertDescription :: TLSError -> AlertDescription errorToAlertDescription = snd . errorToAlert --- | Encode an alert to the assigned value.-fromAlertDescription :: AlertDescription -> Word8-fromAlertDescription = valOfType- -- | Decode an alert from the assigned value.-toAlertDescription :: Word8 -> Maybe AlertDescription-toAlertDescription = valToType+toAlertDescription :: Word8 -> AlertDescription+toAlertDescription = AlertDescription defaultSupported :: Supported-defaultSupported = def- { supportedVersions = [TLS13]- , supportedCiphers = [ cipher_TLS13_AES256GCM_SHA384- , cipher_TLS13_AES128GCM_SHA256- , cipher_TLS13_AES128CCM_SHA256- ]- , supportedGroups = [X25519,X448,P256,P384,P521]- }+defaultSupported =+ def+ { supportedVersions = [TLS13]+ , supportedCiphers =+ [ cipher13_AES_256_GCM_SHA384+ , cipher13_AES_128_GCM_SHA256+ , cipher13_AES_128_CCM_SHA256+ ]+ , supportedGroups = [X25519, X448, P256, P384, P521]+ } -- | Max early data size for QUIC. quicMaxEarlyDataSize :: Int
Network/TLS/RNG.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Network.TLS.RNG- ( StateRNG(..)- , Seed- , seedNew- , seedToInteger- , seedFromInteger- , withTLSRNG- , newStateRNG- , MonadRandom- , getRandomBytes- ) where -import Crypto.Random.Types+module Network.TLS.RNG (+ StateRNG (..),+ Seed,+ seedNew,+ seedToInteger,+ seedFromInteger,+ withTLSRNG,+ newStateRNG,+ MonadRandom,+ getRandomBytes,+) where+ import Crypto.Random newtype StateRNG = StateRNG ChaChaDRG@@ -20,9 +20,10 @@ instance Show StateRNG where show _ = "rng[..]" -withTLSRNG :: StateRNG- -> MonadPseudoRandom StateRNG a- -> (a, StateRNG)+withTLSRNG+ :: StateRNG+ -> MonadPseudoRandom StateRNG a+ -> (a, StateRNG) withTLSRNG rng f = withDRG rng f newStateRNG :: Seed -> StateRNG
− Network/TLS/Receiving.hs
@@ -1,102 +0,0 @@--- |--- Module : Network.TLS.Receiving--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Receiving module contains calls related to unmarshalling packets according--- to the TLS state----{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Receiving- ( processPacket- , processPacket13- ) where--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--import Control.Concurrent.MVar-import Control.Monad.State.Strict--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 _ (Record ProtocolType_DeprecatedHandshake _ fragment) =- case decodeDeprecatedHandshake $ fragmentGetBytes fragment of- Left err -> return $ Left err- Right hs -> return $ Right $ Handshake [hs]--switchRxEncryption :: Context -> IO ()-switchRxEncryption ctx =- usingHState ctx (gets hstPendingRxState) >>= \rx ->- liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" 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 _ (Record ProtocolType_DeprecatedHandshake _ _) =- return (Left $ Error_Packet "deprecated handshake packet 1.3")
Network/TLS/Record.hs view
@@ -1,42 +1,36 @@--- |--- Module : Network.TLS.Record--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ 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.----module Network.TLS.Record- ( Record(..)+-- | 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.+module Network.TLS.Record (+ Record (..),+ -- * Fragment manipulation types- , Fragment- , fragmentGetBytes- , fragmentPlaintext- , fragmentCiphertext- , recordToRaw- , rawToRecord- , recordToHeader- , Plaintext- , Compressed- , Ciphertext- -- * Engage and disengage from the record layer- , engageRecord- , disengageRecord+ Fragment,+ fragmentGetBytes,+ fragmentPlaintext,+ fragmentCiphertext,+ recordToRaw,+ rawToRecord,+ recordToHeader,+ Plaintext,+ Ciphertext,++ -- * Encrypt and decrypt from the record layer+ encryptRecord,+ decryptRecord,+ -- * State tracking- , RecordM- , runRecordM- , RecordState(..)- , newRecordState- , getRecordVersion- , setRecordIV- ) where+ RecordM,+ runRecordM,+ RecordState (..),+ newRecordState,+ getRecordVersion,+ setRecordIV,+) where -import Network.TLS.Record.Types-import Network.TLS.Record.Engage-import Network.TLS.Record.Disengage+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,207 @@+{-# 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++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++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++ 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 = 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++ -- 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/Disengage.hs
@@ -1,201 +0,0 @@--- |--- Module : Network.TLS.Record.Disengage--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Disengage a record from the Record layer.--- The record is decrypted, checked for integrity and then decompressed.------ Starting with TLS v1.3, only the "null" compression method is negotiated in--- the handshake, so the decompression step will be a no-op. Decryption and--- integrity verification are performed using an AEAD cipher only.----{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Record.Disengage- ( disengageRecord- ) where--import Control.Monad.State.Strict--import Crypto.Cipher.Types (AuthTag(..))-import Network.TLS.Struct-import Network.TLS.ErrT-import Network.TLS.Cap-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Cipher-import Network.TLS.Crypto-import Network.TLS.Compression-import Network.TLS.Util-import Network.TLS.Wire-import Network.TLS.Packet-import Network.TLS.Imports-import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert, xor)--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, True, UnexpectedMessage)- Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d)- ProtocolType_ChangeCipherSpec -> noDecryption- ProtocolType_Alert -> noDecryption- _ -> throwError $ Error_Protocol ("illegal plain text", True, UnexpectedMessage)--unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)-unInnerPlaintext inner =- case B.unsnoc dc of- Nothing -> Left $ unknownContentType13 (0 :: Word8)- Just (bytes,c) ->- case valToType c of- Nothing -> Left $ unknownContentType13 c- Just ct- | B.null bytes && ct `elem` nonEmptyContentTypes ->- Left ("empty " ++ show ct ++ " record disallowed")- | otherwise -> Right (ct, 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 `bytesEq` 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- cver <- getRecordVersion- let b = B.length pad - 1- return $ if cver < TLS10- then b < blksz- else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad-- unless (macValid &&! paddingValid) $- throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)-- return $ cipherDataContent cdata--decryptData :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString-decryptData ver record econtent tst = decryptOf (cstKey cst)- where cipher = fromJust "cipher" $ stCipher tst- bulk = cipherBulk cipher- cst = stCryptState tst- macSize = hashDigestSize $ cipherHash cipher- blockSize = bulkBlockSize bulk- econtentLen = B.length econtent-- explicitIV = hasExplicitBlockIV ver-- sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters")-- decryptOf :: BulkState -> RecordM ByteString- decryptOf (BulkStateBlock decryptF) = do- let minContent = (if explicitIV then bulkIVSize bulk else 0) + 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') <- if explicitIV- then get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)- else return (cstIV cst, econtent)- 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", True, BadRecordMac)-- modify incrRecordState- return content-- decryptOf BulkStateUninitialized =- throwError $ Error_Protocol ("decrypt state uninitialized", True, 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", True, 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,146 +0,0 @@--- |--- Module : Network.TLS.Record.Engage--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ 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.----{-# LANGUAGE BangPatterns #-}-module Network.TLS.Record.Engage- ( engageRecord- ) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag(..))--import Network.TLS.Cap-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Wire-import Network.TLS.Packet-import Network.TLS.Struct-import Network.TLS.Imports-import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert, xor)--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 ct bytes = runPut $ do- putBytes bytes- putWord8 $ valOfType ct -- 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- ver <- getRecordVersion- 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 ]-- if hasExplicitBlockIV ver- then return $ B.concat [cstIV cst,e]- else do- modify $ \tstate -> tstate { stCryptState = cst { cstIV = iv' } }- return 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
@@ -1,63 +1,64 @@-{-# LANGUAGE OverloadedStrings #-}- module Network.TLS.Record.Layer (- RecordLayer(..)- , newTransparentRecordLayer- ) where+ RecordLayer (..),+ newTransparentRecordLayer,+) where +import Network.TLS.Context import Network.TLS.Imports import Network.TLS.Record import Network.TLS.Struct import qualified Data.ByteString as B -data RecordLayer bytes = RecordLayer {- -- Writing.hs- recordEncode :: Record Plaintext -> IO (Either TLSError bytes)- , recordEncode13 :: Record Plaintext -> IO (Either TLSError bytes)- , recordSendBytes :: bytes -> IO ()-- -- Reading.hs- , recordRecv :: Bool -> Int -> IO (Either TLSError (Record Plaintext))- , recordRecv13 :: IO (Either TLSError (Record Plaintext))- }--newTransparentRecordLayer :: Eq ann- => IO ann -> ([(ann, ByteString)] -> IO ())- -> IO (Either TLSError ByteString)- -> RecordLayer [(ann, ByteString)]-newTransparentRecordLayer get send recv = RecordLayer {- recordEncode = transparentEncodeRecord get- , recordEncode13 = transparentEncodeRecord get- , recordSendBytes = transparentSendBytes send- , recordRecv = \_ _ -> transparentRecvRecord recv- , recordRecv13 = transparentRecvRecord recv- }+newTransparentRecordLayer+ :: Eq ann+ => (Context -> IO ann)+ -> ([(ann, ByteString)] -> IO ())+ -> (Context -> IO (Either TLSError ByteString))+ -> RecordLayer [(ann, ByteString)]+newTransparentRecordLayer get send recv =+ RecordLayer+ { recordEncode12 = transparentEncodeRecord get+ , recordEncode13 = transparentEncodeRecord get+ , recordSendBytes = transparentSendBytes send+ , recordRecv12 = transparentRecvRecord recv+ , recordRecv13 = transparentRecvRecord recv+ } -transparentEncodeRecord :: IO ann -> Record Plaintext -> IO (Either TLSError [(ann, ByteString)])-transparentEncodeRecord _ (Record ProtocolType_ChangeCipherSpec _ _) =+transparentEncodeRecord+ :: (Context -> IO ann)+ -> Context+ -> Record Plaintext+ -> IO (Either TLSError [(ann, ByteString)])+transparentEncodeRecord _ _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right []-transparentEncodeRecord _ (Record ProtocolType_Alert _ _) =+transparentEncodeRecord _ _ (Record ProtocolType_Alert _ _) = -- all alerts are silent and must be transported externally based on -- TLS exceptions raised by the library return $ Right []-transparentEncodeRecord get (Record _ _ frag) =- get >>= \a -> return $ Right [(a, fragmentGetBytes frag)]+transparentEncodeRecord get ctx (Record _ _ frag) =+ get ctx >>= \a -> return $ Right [(a, fragmentGetBytes frag)] -transparentSendBytes :: Eq ann => ([(ann, ByteString)] -> IO ()) -> [(ann, ByteString)] -> IO ()-transparentSendBytes send input = send- [ (a, bs) | (a, frgs) <- compress input- , let bs = B.concat frgs- , not (B.null bs)- ]+transparentSendBytes+ :: Eq ann+ => ([(ann, ByteString)] -> IO ())+ -> Context+ -> [(ann, ByteString)]+ -> IO ()+transparentSendBytes send _ input =+ send+ [ (a, bs) | (a, frgs) <- compress input, let bs = B.concat frgs, not (B.null bs)+ ] -transparentRecvRecord :: IO (Either TLSError ByteString)- -> IO (Either TLSError (Record Plaintext))-transparentRecvRecord recv =- fmap (Record ProtocolType_Handshake TLS12 . fragmentPlaintext) <$> recv+transparentRecvRecord+ :: (Context -> IO (Either TLSError ByteString))+ -> Context+ -> IO (Either TLSError (Record Plaintext))+transparentRecvRecord recv ctx =+ fmap (Record ProtocolType_Handshake TLS12 . fragmentPlaintext) <$> recv ctx compress :: Eq ann => [(ann, val)] -> [(ann, [val])]-compress [] = []-compress ((a,v):xs) =+compress [] = []+compress ((a, v) : xs) = let (ys, zs) = span ((== a) . fst) xs in (a, v : map snd ys) : compress zs
− Network/TLS/Record/Reading.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Network.TLS.Record.Reading--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ TLS record layer in Rx direction----module Network.TLS.Record.Reading- ( recvRecord- , recvRecord13- ) where--import Control.Monad.Reader-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- runRxState 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", True, 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- -> Bool -- ^ flag to enable SSLv2 compat ClientHello reception- -> Int -- ^ number of AppData bytes to accept above normal maximum size- -> IO (Either TLSError (Record Plaintext))-recvRecord ctx compatSSLv2 appDataOverhead-#ifdef SSLV2_COMPATIBLE- | compatSSLv2 = readExactBytes ctx 2 >>= either (return . Left) sslv2Header-#endif- | otherwise = 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)-#ifdef SSLV2_COMPATIBLE- sslv2Header header =- if B.head header >= 0x80- then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header- else readExactBytes ctx 3 >>=- either (return . Left) (recvLengthE . decodeHeader . B.append header)-- recvDeprecatedLength readlen- | readlen > 1024 * 4 = return $ Left maximumSizeExceeded- | otherwise = do- res <- readExactBytes ctx (fromIntegral readlen)- case res of- Left e -> return $ Left e- Right content ->- let hdr = decodeDeprecatedHeader readlen (B.take 3 content)- in either (return . Left) (\h -> getRecord ctx appDataOverhead h content) hdr-#endif--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", True, 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,112 @@+-- | 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)+ 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)+ 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++----------------------------------------------------------------++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
@@ -1,106 +1,111 @@ {-# LANGUAGE MultiParamTypeClasses #-}--- |--- Module : Network.TLS.Record.State--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Record.State- ( CryptState(..)- , CryptLevel(..)- , HasCryptLevel(..)- , MacState(..)- , RecordOptions(..)- , RecordState(..)- , newRecordState- , incrRecordState- , RecordM- , runRecordM- , getRecordOptions- , getRecordVersion- , setRecordIV- , withCompression- , computeDigest- , makeDigest- , getBulk- , getMacSequence- ) where +module Network.TLS.Record.State (+ CryptState (..),+ CryptLevel (..),+ HasCryptLevel (..),+ MacState (..),+ RecordOptions (..),+ RecordState (..),+ newRecordState,+ incrRecordState,+ RecordM,+ runRecordM,+ getRecordOptions,+ getRecordVersion,+ setRecordIV,+ withCompression,+ computeDigest,+ makeDigest,+ getBulk,+ getMacSequence,+) where+ import Control.Monad.State.Strict-import Network.TLS.Compression+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+ import Network.TLS.Cipher+import Network.TLS.Compression import Network.TLS.ErrT-import Network.TLS.Struct-import Network.TLS.Wire--import Network.TLS.Packet-import Network.TLS.MAC-import Network.TLS.Util import Network.TLS.Imports+import Network.TLS.MAC+import Network.TLS.Packet+import Network.TLS.Struct import Network.TLS.Types--import qualified Data.ByteString as B+import Network.TLS.Wire data CryptState = CryptState- { cstKey :: !BulkState- , cstIV :: !ByteString- -- In TLS 1.2 or earlier, this holds mac secret.- -- In TLS 1.3, this holds application traffic secret N.- , cstMacSecret :: !ByteString- } deriving (Show)+ { cstKey :: BulkState+ , cstIV :: IV+ , -- In TLS 1.2 or earlier, this holds mac secret.+ -- In TLS 1.3, this holds application traffic secret N.+ cstMacSecret :: Secret+ }+ deriving (Show) newtype MacState = MacState { msSequence :: Word64- } deriving (Show)+ }+ deriving (Show) data RecordOptions = RecordOptions- { recordVersion :: Version -- version to use when sending/receiving- , recordTLS13 :: Bool -- TLS13 record processing+ { recordVersion :: Version -- version to use when sending/receiving+ , recordTLS13 :: Bool -- TLS13 record processing } -- | TLS encryption level. data CryptLevel- = CryptInitial -- ^ Unprotected traffic- | CryptMasterSecret -- ^ Protected with master secret (TLS < 1.3)- | CryptEarlySecret -- ^ Protected with early traffic secret (TLS 1.3)- | CryptHandshakeSecret -- ^ Protected with handshake traffic secret (TLS 1.3)- | CryptApplicationSecret -- ^ Protected with application traffic secret (TLS 1.3)- deriving (Eq,Show)+ = -- | Unprotected traffic+ CryptInitial+ | -- | Protected with main secret (TLS < 1.3)+ CryptMainSecret+ | -- | Protected with early traffic secret (TLS 1.3)+ CryptEarlySecret+ | -- | Protected with handshake traffic secret (TLS 1.3)+ CryptHandshakeSecret+ | -- | Protected with application traffic secret (TLS 1.3)+ CryptApplicationSecret+ deriving (Eq, Show) class HasCryptLevel a where getCryptLevel :: proxy a -> CryptLevel instance HasCryptLevel EarlySecret where getCryptLevel _ = CryptEarlySecret-instance HasCryptLevel HandshakeSecret where getCryptLevel _ = CryptHandshakeSecret-instance HasCryptLevel ApplicationSecret where getCryptLevel _ = CryptApplicationSecret+instance HasCryptLevel HandshakeSecret where+ getCryptLevel _ = CryptHandshakeSecret+instance HasCryptLevel ApplicationSecret where+ getCryptLevel _ = CryptApplicationSecret data RecordState = RecordState- { stCipher :: Maybe Cipher+ { stCipher :: Maybe Cipher , stCompression :: Compression- , stCryptLevel :: !CryptLevel- , stCryptState :: !CryptState- , stMacState :: !MacState- } deriving (Show)+ , stCryptLevel :: CryptLevel+ , stCryptState :: CryptState+ , stMacState :: MacState+ }+ deriving (Show) -newtype RecordM a = RecordM { runRecordM :: RecordOptions- -> RecordState- -> Either TLSError (a, RecordState) }+newtype RecordM a = RecordM+ { runRecordM+ :: RecordOptions+ -> RecordState+ -> Either TLSError (a, RecordState)+ } instance Applicative RecordM where- pure = return+ pure a = RecordM $ \_ st -> Right (a, st) (<*>) = ap instance Monad RecordM where- return a = RecordM $ \_ st -> Right (a, st) m1 >>= m2 = RecordM $ \opt st ->- case runRecordM m1 opt st of- Left err -> Left err- Right (a, st2) -> runRecordM (m2 a) opt st2+ case runRecordM m1 opt st of+ Left err -> Left err+ Right (a, st2) -> runRecordM (m2 a) opt st2 instance Functor RecordM where fmap f m = RecordM $ \opt st ->- case runRecordM m opt st of- Left err -> Left err- Right (a, st2) -> Right (f a, st2)+ case runRecordM m opt st of+ Left err -> Left err+ Right (a, st2) -> Right (f a, st2) getRecordOptions :: RecordM RecordOptions getRecordOptions = RecordM $ \opt st -> Right (opt, st)@@ -109,51 +114,53 @@ getRecordVersion = recordVersion <$> getRecordOptions instance MonadState RecordState RecordM where- put x = RecordM $ \_ _ -> Right ((), x)- get = RecordM $ \_ st -> Right (st, st)+ put x = RecordM $ \_ _ -> Right ((), x)+ get = RecordM $ \_ st -> Right (st, st) state f = RecordM $ \_ st -> Right (f st) instance MonadError TLSError RecordM where- throwError e = RecordM $ \_ _ -> Left e+ throwError e = RecordM $ \_ _ -> Left e catchError m f = RecordM $ \opt st ->- case runRecordM m opt st of- Left err -> runRecordM (f err) opt st- r -> r+ case runRecordM m opt st of+ Left err -> runRecordM (f err) opt st+ r -> r newRecordState :: RecordState-newRecordState = RecordState- { stCipher = Nothing- , stCompression = nullCompression- , stCryptLevel = CryptInitial- , stCryptState = CryptState BulkStateUninitialized B.empty B.empty- , stMacState = MacState 0- }+newRecordState =+ RecordState+ { stCipher = Nothing+ , stCompression = nullCompression+ , stCryptLevel = CryptInitial+ , stCryptState = CryptState BulkStateUninitialized B.empty BA.empty+ , stMacState = MacState 0+ } incrRecordState :: RecordState -> RecordState-incrRecordState ts = ts { stMacState = MacState (ms + 1) }- where (MacState ms) = stMacState ts+incrRecordState ts = ts{stMacState = MacState (ms + 1)}+ where+ (MacState ms) = stMacState ts setRecordIV :: ByteString -> RecordState -> RecordState-setRecordIV iv st = st { stCryptState = (stCryptState st) { cstIV = iv } }+setRecordIV iv st = st{stCryptState = (stCryptState st){cstIV = iv}} withCompression :: (Compression -> (Compression, a)) -> RecordM a withCompression f = do st <- get let (nc, a) = f $ stCompression st- put $ st { stCompression = nc }+ put $ st{stCompression = nc} return a -computeDigest :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState)-computeDigest ver tstate hdr content = (digest, incrRecordState tstate)- where digest = macF (cstMacSecret cst) msg- cst = stCryptState tstate- cipher = fromJust "cipher" $ stCipher tstate- hashA = cipherHash cipher- encodedSeq = encodeWord64 $ msSequence $ stMacState tstate+computeDigest+ :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState)+computeDigest _ver tstate hdr content = (digest, incrRecordState tstate)+ where+ digest = BA.convert $ macF (cstMacSecret cst) msg+ cst = stCryptState tstate+ cipher = fromJust $ stCipher tstate+ hashA = cipherHash cipher+ encodedSeq = encodeWord64 $ msSequence $ stMacState tstate - (macF, msg)- | ver < TLS10 = (macSSL hashA, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ])- | otherwise = (hmac hashA, B.concat [ encodedSeq, encodeHeader hdr, content ])+ (macF, msg) = (hmac hashA, B.concat [encodedSeq, encodeHeader hdr, content]) makeDigest :: Header -> ByteString -> RecordM ByteString makeDigest hdr content = do@@ -164,7 +171,7 @@ return digest getBulk :: RecordM Bulk-getBulk = cipherBulk . fromJust "cipher" . stCipher <$> get+getBulk = cipherBulk . fromJust . stCipher <$> get getMacSequence :: RecordM Word64 getMacSequence = msSequence . stMacState <$> get
Network/TLS/Record/Types.hs view
@@ -1,88 +1,78 @@ {-# LANGUAGE EmptyDataDecls #-}--- |--- Module : Network.TLS.Record.Types--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ 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.----module Network.TLS.Record.Types- ( Header(..)- , ProtocolType(..)- , packetType++-- | The Record Protocol takes messages to be transmitted, fragments+-- 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 (..),+ packetType,+ -- * TLS Records- , Record(..)+ Record (..),+ -- * TLS Record fragment and constructors- , Fragment- , fragmentGetBytes- , fragmentPlaintext- , fragmentCompressed- , fragmentCiphertext- , Plaintext- , Compressed- , Ciphertext+ Fragment,+ fragmentGetBytes,+ fragmentPlaintext,+ fragmentCiphertext,+ Plaintext,+ Ciphertext,+ -- * manipulate record- , onRecordFragment- , fragmentCompress- , fragmentCipher- , fragmentUncipher- , fragmentUncompress+ onRecordFragment,+ fragmentCipher,+ fragmentUncipher,+ -- * serialize record- , rawToRecord- , recordToRaw- , recordToHeader- ) where+ rawToRecord,+ recordToRaw,+ recordToHeader,+) where -import Network.TLS.Struct+import qualified Data.ByteString as B+ import Network.TLS.Imports import Network.TLS.Record.State-import qualified Data.ByteString as B+import Network.TLS.Struct -- | Represent a TLS record.-data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)+data Record a = Record ProtocolType Version (Fragment a) deriving (Show, Eq) -newtype Fragment a = Fragment { fragmentGetBytes :: ByteString } deriving (Show,Eq)+newtype Fragment a = Fragment {fragmentGetBytes :: ByteString}+ 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 -onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b)+onRecordFragment+ :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag -fragmentMap :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b)+fragmentMap+ :: (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 -> RecordM (Fragment Ciphertext)+fragmentCipher+ :: (ByteString -> RecordM ByteString)+ -> Fragment Plaintext+ -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f --- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied-fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext -> RecordM (Fragment Compressed)+-- | turn a ciphertext fragment into a plaintext fragment using the cipher function supplied+fragmentUncipher+ :: (ByteString -> RecordM ByteString)+ -> Fragment Ciphertext+ -> RecordM (Fragment Plaintext) 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 -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, ByteString)
− Network/TLS/Record/Writing.hs
@@ -1,69 +0,0 @@--- |--- Module : Network.TLS.Record.Writing--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ TLS record layer in Tx direction----module Network.TLS.Record.Writing- ( encodeRecord- , encodeRecord13- , sendBytes- ) where--import Network.TLS.Cap-import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Parameters-import Network.TLS.Record-import Network.TLS.State-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- ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)- txState <- readMVar $ ctxTxState 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 hasExplicitBlockIV ver && sz > 0- then do newIV <- getStateRNG ctx sz- runTxState ctx (modify (setRecordIV newIV) >> f)- else runTxState 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 = runTxState--------------------------------------------------------------------sendBytes :: Context -> ByteString -> IO ()-sendBytes ctx dataToSend = do- withLog ctx $ \logging -> loggingIOSent logging dataToSend- contextSend ctx dataToSend
− Network/TLS/Sending.hs
@@ -1,121 +0,0 @@--- |--- Module : Network.TLS.Sending--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Sending module contains calls related to marshalling packets according--- to the TLS state----module Network.TLS.Sending (- encodePacket- , encodePacket13- , updateHandshake- , updateHandshake13- ) where--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.Record.Layer-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types (Role(..))-import Network.TLS.Util--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B-import Data.IORef---- | encodePacket transform a packet into marshalled data related to current state--- and updating state on the go-encodePacket :: Monoid bytes- => Context -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)-encodePacket ctx recordLayer pkt = do- (ver, _) <- decideRecordVersion ctx- let pt = packetType pkt- mkRecord bs = Record pt ver (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments ctx len pkt- bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer)- 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.-packetToFragments :: Context -> Maybe Int -> Packet -> IO [ByteString]-packetToFragments ctx len (Handshake hss) =- getChunks len . B.concat <$> mapM (updateHandshake ctx ClientRole) hss-packetToFragments _ _ (Alert a) = return [encodeAlerts a]-packetToFragments _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]-packetToFragments _ _ (AppData x) = return [x]--switchTxEncryption :: Context -> IO ()-switchTxEncryption ctx = do- tx <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState)- (ver, cc) <- usingState_ ctx $ do v <- getVersion- c <- isClientContext- return (v, c)- liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx)- -- set empty packet counter measure if condition are met- when (ver <= TLS10 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True- where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)--updateHandshake :: Context -> Role -> Handshake -> IO ByteString-updateHandshake ctx role hs = do- case hs of- Finished fdata -> usingState_ ctx $ updateVerifiedData role fdata- _ -> return ()- usingHState ctx $ do- when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded- when (finishHandshakeTypeMaterial $ typeOfHandshake 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)--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
@@ -1,34 +1,35 @@--- |--- Module : Network.TLS.Session--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Session- ( SessionManager(..)- , noSessionManager- ) where+module Network.TLS.Session (+ SessionManager (..),+ noSessionManager,+) where 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- { -- | used on server side to decide whether to resume a client session.- sessionResume :: SessionID -> IO (Maybe SessionData)- -- | used on server side to decide whether to resume a client session for TLS 1.3 0RTT. For a given 'SessionID', the implementation must return its 'SessionData' only once and must not return the same 'SessionData' after the call.- , sessionResumeOnlyOnce :: SessionID -> IO (Maybe SessionData)- -- | used when a session is established.- , sessionEstablish :: SessionID -> SessionData -> IO ()- -- | used when a session is invalidated.- , sessionInvalidate :: SessionID -> IO ()+ { 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 :: 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 'SessionID' and 'Ticket' are integrated as identity in TLS 1.3. } -- | The session manager to do nothing. noSessionManager :: SessionManager-noSessionManager = SessionManager- { sessionResume = \_ -> return Nothing- , sessionResumeOnlyOnce = \_ -> return Nothing- , sessionEstablish = \_ _ -> return ()- , sessionInvalidate = \_ -> return ()- }+noSessionManager =+ SessionManager+ { sessionResume = \_ -> return Nothing+ , sessionResumeOnlyOnce = \_ -> return Nothing+ , sessionEstablish = \_ _ -> return Nothing+ , sessionInvalidate = \_ -> return ()+ , -- Don't send NewSessionTicket in TLS 1.2 by default.+ -- Send NewSessionTicket with SessionID in TLS 1.3 by default.+ sessionUseTicket = False+ }
Network/TLS/State.hs view
@@ -1,253 +1,325 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}--- |--- Module : Network.TLS.State--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the State module contains calls related to state initialization/manipulation--- which is use by the Receiving module and the Sending module.----module Network.TLS.State- ( TLSState(..)- , TLSSt- , runTLSState- , newTLSState- , withTLSRNG- , updateVerifiedData- , finishHandshakeTypeMaterial- , finishHandshakeMaterial- , certVerifyHandshakeTypeMaterial- , certVerifyHandshakeMaterial- , setVersion- , setVersionIfUnset- , getVersion- , getVersionWithDefault- , setSecureRenegotiation- , getSecureRenegotiation- , setExtensionALPN- , getExtensionALPN- , setNegotiatedProtocol- , getNegotiatedProtocol- , setClientALPNSuggest- , getClientALPNSuggest- , setClientEcPointFormatSuggest- , getClientEcPointFormatSuggest- , getClientCertificateChain- , setClientCertificateChain- , setClientSNI- , getClientSNI- , getVerifiedData- , setSession- , getSession- , isSessionResuming- , isClientContext- , setExporterMasterSecret- , getExporterMasterSecret- , setTLS13KeyShare- , getTLS13KeyShare- , setTLS13PreSharedKey- , getTLS13PreSharedKey- , setTLS13HRR- , getTLS13HRR- , setTLS13Cookie- , getTLS13Cookie- , setClientSupportsPHA- , getClientSupportsPHA+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}++-- | the State module contains calls related to state+-- initialization/manipulation which is use by the Receiving module+-- and the Sending module.+module Network.TLS.State (+ TLSState (..),+ TLSSt,+ runTLSState,+ newTLSState,+ withTLSRNG,+ setVerifyDataForSend,+ setVerifyDataForRecv,+ getVerifyData,+ getMyVerifyData,+ getPeerVerifyData,+ getFirstVerifyData,+ finishedHandshakeTypeMaterial,+ finishedHandshakeMaterial,+ certVerifyHandshakeTypeMaterial,+ certVerifyHandshakeMaterial,+ setVersion,+ setVersionIfUnset,+ getVersion,+ getVersionWithDefault,+ setSecureRenegotiation,+ getSecureRenegotiation,+ setExtensionALPN,+ getExtensionALPN,+ setNegotiatedProtocol,+ getNegotiatedProtocol,+ setClientALPNSuggest,+ getClientALPNSuggest,+ setClientEcPointFormatSuggest,+ getClientEcPointFormatSuggest,+ setClientSNI,+ clearClientSNI,+ getClientSNI,+ getClientCertificateChain,+ setClientCertificateChain,+ getServerCertificateChain,+ setServerCertificateChain,+ setSession,+ getSession,+ getRole,+ --+ setTLS12SessionResuming,+ getTLS12SessionResuming,+ --+ setTLS13ExporterSecret,+ getTLS13ExporterSecret,+ setTLS13KeyShare,+ getTLS13KeyShare,+ setTLS13PreSharedKey,+ getTLS13PreSharedKey,+ setTLS13HRR,+ getTLS13HRR,+ setTLS13Cookie,+ getTLS13Cookie,+ setTLS13ClientSupportsPHA,+ getTLS13ClientSupportsPHA,+ setTLS12SessionTicket,+ getTLS12SessionTicket,+ -- * random- , genRandom- , withRNG- ) where+ genRandom,+ withRNG,+) where -import Network.TLS.Imports-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.RNG-import Network.TLS.Types (Role(..), HostName)-import Network.TLS.Wire (GetContinuation)-import Network.TLS.Extension-import qualified Data.ByteString as B import Control.Monad.State.Strict-import Network.TLS.ErrT import Crypto.Random 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 (..), Secret, Ticket, WireBytes)+import Network.TLS.Wire (GetContinuation)+ data TLSState = TLSState- { stSession :: Session- , stSessionResuming :: Bool- , stSecureRenegotiation :: Bool -- RFC 5746- , stClientVerifiedData :: ByteString -- RFC 5746- , stServerVerifiedData :: ByteString -- RFC 5746- , stExtensionALPN :: Bool -- RFC 7301- , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString))- , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol- , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, ByteString))- , stClientALPNSuggest :: Maybe [B.ByteString]- , stClientGroupSuggest :: Maybe [Group]+ { stSession :: Session+ , -- RFC 5746, Renegotiation Indication Extension+ -- RFC 5929, Channel Bindings for TLS, "tls-unique"+ stSecureRenegotiation :: Bool+ , stClientVerifyData :: Maybe VerifyData+ , stServerVerifyData :: Maybe VerifyData+ , -- RFC 5929, Channel Bindings for TLS, "tls-server-end-point"+ stServerCertificateChain :: Maybe CertificateChain+ , stExtensionALPN :: Bool -- RFC 7301+ , 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- , stTLS13PreSharedKey :: Maybe PreSharedKey- , stTLS13HRR :: !Bool- , stTLS13Cookie :: Maybe Cookie- , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3- , stClientSupportsPHA :: !Bool -- Post-Handshake Authentication (TLS 1.3)+ , stClientSNI :: Maybe HostName+ , stRandomGen :: StateRNG+ , stClientContext :: Role+ , stVersion :: Maybe Version+ , --+ stTLS12SessionResuming :: Bool+ , stTLS12SessionTicket :: Maybe Ticket+ , --+ stTLS13KeyShare :: Maybe KeyShare+ , stTLS13PreSharedKey :: Maybe PreSharedKey+ , stTLS13HRR :: Bool+ , stTLS13Cookie :: Maybe Cookie+ , stTLS13ExporterSecret :: Maybe Secret+ , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } -newtype TLSSt a = TLSSt { runTLSSt :: ErrT TLSError (State TLSState) a }+newtype TLSSt a = TLSSt {runTLSSt :: ErrT TLSError (State TLSState) a} deriving (Monad, MonadError TLSError, Functor, Applicative) instance MonadState TLSState TLSSt where put x = TLSSt (lift $ put x)- get = TLSSt (lift get)+ get = TLSSt (lift get) state f = TLSSt (lift $ state f) runTLSState :: TLSSt a -> TLSState -> (Either TLSError a, TLSState) runTLSState f st = runState (runErrT (runTLSSt f)) st newTLSState :: StateRNG -> Role -> TLSState-newTLSState rng clientContext = TLSState- { stSession = Session Nothing- , stSessionResuming = False- , stSecureRenegotiation = False- , stClientVerifiedData = B.empty- , stServerVerifiedData = B.empty- , stExtensionALPN = False- , stHandshakeRecordCont = Nothing- , stHandshakeRecordCont13 = Nothing- , stNegotiatedProtocol = Nothing- , stClientALPNSuggest = Nothing- , stClientGroupSuggest = Nothing- , stClientEcPointFormatSuggest = Nothing- , stClientCertificateChain = Nothing- , stClientSNI = Nothing- , stRandomGen = rng- , stVersion = Nothing- , stClientContext = clientContext- , stTLS13KeyShare = Nothing- , stTLS13PreSharedKey = Nothing- , stTLS13HRR = False- , stTLS13Cookie = Nothing- , stExporterMasterSecret = Nothing- , stClientSupportsPHA = False- }+newTLSState rng clientContext =+ TLSState+ { stSession = Session Nothing+ , stSecureRenegotiation = False+ , stClientVerifyData = Nothing+ , stServerVerifyData = Nothing+ , stServerCertificateChain = Nothing+ , stExtensionALPN = False+ , stNegotiatedProtocol = Nothing+ , stHandshakeRecordCont12 = (Nothing, [])+ , stHandshakeRecordCont13 = (Nothing, [])+ , stClientALPNSuggest = Nothing+ , stClientGroupSuggest = Nothing+ , stClientEcPointFormatSuggest = Nothing+ , stClientCertificateChain = Nothing+ , stClientSNI = Nothing+ , stRandomGen = rng+ , stClientContext = clientContext+ , stVersion = Nothing+ , stTLS12SessionResuming = False+ , stTLS12SessionTicket = Nothing+ , stTLS13KeyShare = Nothing+ , stTLS13PreSharedKey = Nothing+ , stTLS13HRR = False+ , stTLS13Cookie = Nothing+ , stTLS13ExporterSecret = Nothing+ , stTLS13ClientSupportsPHA = False+ } -updateVerifiedData :: Role -> ByteString -> TLSSt ()-updateVerifiedData sending bs = do- cc <- isClientContext- if cc /= sending- then modify (\st -> st { stServerVerifiedData = bs })- else modify (\st -> st { stClientVerifiedData = bs })+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}) -finishHandshakeTypeMaterial :: HandshakeType -> Bool-finishHandshakeTypeMaterial HandshakeType_ClientHello = True-finishHandshakeTypeMaterial HandshakeType_ServerHello = True-finishHandshakeTypeMaterial HandshakeType_Certificate = True-finishHandshakeTypeMaterial HandshakeType_HelloRequest = False-finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True-finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True-finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True-finishHandshakeTypeMaterial HandshakeType_CertRequest = True-finishHandshakeTypeMaterial HandshakeType_CertVerify = True-finishHandshakeTypeMaterial HandshakeType_Finished = True+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}) -finishHandshakeMaterial :: Handshake -> Bool-finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake+finishedHandshakeTypeMaterial :: HandshakeType -> Bool+finishedHandshakeTypeMaterial HandshakeType_ClientHello = True+finishedHandshakeTypeMaterial HandshakeType_ServerHello = True+finishedHandshakeTypeMaterial HandshakeType_Certificate = True+-- finishedHandshakeTypeMaterial HandshakeType_HelloRequest = False+finishedHandshakeTypeMaterial HandshakeType_ServerHelloDone = True+finishedHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True+finishedHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True+finishedHandshakeTypeMaterial HandshakeType_CertRequest = True+finishedHandshakeTypeMaterial HandshakeType_CertVerify = True+finishedHandshakeTypeMaterial HandshakeType_NewSessionTicket = True+finishedHandshakeTypeMaterial HandshakeType_Finished = True+finishedHandshakeTypeMaterial _ = False +finishedHandshakeMaterial :: Handshake -> Bool+finishedHandshakeMaterial = finishedHandshakeTypeMaterial . typeOfHandshake+ certVerifyHandshakeTypeMaterial :: HandshakeType -> Bool-certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True-certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True-certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True-certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False+certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True+certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True+certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True+-- certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False certVerifyHandshakeTypeMaterial HandshakeType_ServerHelloDone = True-certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True-certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True-certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True-certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False-certVerifyHandshakeTypeMaterial HandshakeType_Finished = False+certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True+certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True+certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True+-- certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False+-- certVerifyHandshakeTypeMaterial HandshakeType_Finished = False+certVerifyHandshakeTypeMaterial _ = False 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- where maybeSet st = case stVersion st of- Nothing -> st { stVersion = Just ver }- Just _ -> st+setVersionIfUnset ver = modify' maybeSet+ where+ maybeSet st = case stVersion st of+ Nothing -> st{stVersion = Just ver}+ Just _ -> st getVersion :: TLSSt Version-getVersion = fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion+getVersion =+ fromMaybe (error "internal error: version hasn't been set yet")+ <$> 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})++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 -getVerifiedData :: Role -> TLSSt ByteString-getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData)+getVerifyData :: Role -> TLSSt VerifyData+getVerifyData client = do+ mVerifyData <-+ gets (if client == ClientRole then stClientVerifyData else stServerVerifyData)+ return $ fromMaybe (VerifyData "") mVerifyData -isClientContext :: TLSSt Role-isClientContext = gets stClientContext+getMyVerifyData :: TLSSt (Maybe VerifyData)+getMyVerifyData = do+ role <- getRole+ if role == ClientRole+ then gets stClientVerifyData+ else gets stServerVerifyData +getPeerVerifyData :: TLSSt (Maybe VerifyData)+getPeerVerifyData = do+ role <- getRole+ if role == ClientRole+ then gets stServerVerifyData+ else gets stClientVerifyData++getFirstVerifyData :: TLSSt (Maybe VerifyData)+getFirstVerifyData = do+ 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+ genRandom :: Int -> TLSSt ByteString genRandom n = do withRNG (getRandomBytes n)@@ -255,42 +327,48 @@ withRNG :: MonadPseudoRandom StateRNG a -> TLSSt a withRNG f = do st <- get- let (a,rng') = withTLSRNG (stRandomGen st) f- put (st { stRandomGen = rng' })+ let (a, rng') = withTLSRNG (stRandomGen st) f+ put (st{stRandomGen = rng'}) return a -setExporterMasterSecret :: ByteString -> TLSSt ()-setExporterMasterSecret key = modify (\st -> st { stExporterMasterSecret = Just key })+setTLS12SessionTicket :: Ticket -> TLSSt ()+setTLS12SessionTicket t = modify' (\st -> st{stTLS12SessionTicket = Just t}) -getExporterMasterSecret :: TLSSt (Maybe ByteString)-getExporterMasterSecret = gets stExporterMasterSecret+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 })+setTLS13ClientSupportsPHA :: Bool -> TLSSt ()+setTLS13ClientSupportsPHA b = modify' (\st -> st{stTLS13ClientSupportsPHA = b}) -getClientSupportsPHA :: TLSSt Bool-getClientSupportsPHA = gets stClientSupportsPHA+getTLS13ClientSupportsPHA :: TLSSt Bool+getTLS13ClientSupportsPHA = gets stTLS13ClientSupportsPHA
Network/TLS/Struct.hs view
@@ -1,81 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE DeriveDataTypeable #-}--- |--- Module : Network.TLS.Struct--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Struct module contains all definitions and values of the TLS protocol----module Network.TLS.Struct- ( Version(..)- , ConnectionEnd(..)- , CipherType(..)- , CipherData(..)- , ExtensionID- , ExtensionRaw(..)- , CertificateType(..)- , lastSupportedCertificateType- , HashAlgorithm(..)- , SignatureAlgorithm(..)- , HashAndSignatureAlgorithm- , DigitallySigned(..)- , Signature- , ProtocolType(..)- , TLSError(..)- , TLSException(..)- , DistinguishedName- , BigNum(..)- , bigNumToInteger- , bigNumFromInteger- , ServerDHParams(..)- , serverDHParamsToParams- , serverDHParamsToPublic- , serverDHParamsFrom- , ServerECDHParams(..)- , ServerRSAParams(..)- , ServerKeyXchgAlgorithmData(..)- , ClientKeyXchgAlgorithmData(..)- , Packet(..)- , Header(..)- , ServerRandom(..)- , ClientRandom(..)- , FinishedData- , SessionID- , Session(..)- , SessionData(..)- , AlertLevel(..)- , AlertDescription(..)- , HandshakeType(..)- , Handshake(..)- , numericalVer- , verOfNum- , TypeValuable, valOfType, valToType- , EnumSafe8(..)- , EnumSafe16(..)- , packetType- , typeOfHandshake- ) where -import Data.X509 (CertificateChain, DistinguishedName)-import Data.Typeable-import Control.Exception (Exception(..))-import Network.TLS.Types+-- | The Struct module contains all definitions and values of the TLS+-- protocol.+module Network.TLS.Struct (+ Version (..),+ CipherData (..),+ CertificateType (+ CertificateType,+ CertificateType_RSA_Sign,+ CertificateType_DSA_Sign,+ CertificateType_ECDSA_Sign,+ CertificateType_Ed25519_Sign,+ CertificateType_Ed448_Sign+ ),+ fromCertificateType,+ lastSupportedCertificateType,+ DigitallySigned (..),+ Signature,+ ProtocolType (+ ..,+ ProtocolType_ChangeCipherSpec,+ ProtocolType_Alert,+ ProtocolType_Handshake,+ ProtocolType_AppData+ ),+ TLSError (..),+ TLSException (..),+ DistinguishedName,+ ServerDHParams (..),+ serverDHParamsToParams,+ serverDHParamsToPublic,+ serverDHParamsFrom,+ ServerECDHParams (..),+ ServerRSAParams (..),+ ServerKeyXchgAlgorithmData (..),+ ClientKeyXchgAlgorithmData (..),+ Packet (..),+ Header (..),+ ServerRandom (..),+ ClientRandom (..),+ FinishedData,+ VerifyData (..),+ SessionID,+ Session (..),+ SessionData (..),+ AlertLevel (+ ..,+ AlertLevel_Warning,+ AlertLevel_Fatal+ ),+ AlertDescription (+ ..,+ CloseNotify,+ UnexpectedMessage,+ BadRecordMac,+ DecryptionFailed,+ RecordOverflow,+ DecompressionFailure,+ HandshakeFailure,+ BadCertificate,+ UnsupportedCertificate,+ CertificateRevoked,+ CertificateExpired,+ CertificateUnknown,+ IllegalParameter,+ UnknownCa,+ AccessDenied,+ DecodeError,+ DecryptError,+ ExportRestriction,+ ProtocolVersion,+ InsufficientSecurity,+ InternalError,+ InappropriateFallback,+ UserCanceled,+ NoRenegotiation,+ MissingExtension,+ UnsupportedExtension,+ CertificateUnobtainable,+ UnrecognizedName,+ BadCertificateStatusResponse,+ BadCertificateHashValue,+ UnknownPskIdentity,+ CertificateRequired,+ NoApplicationProtocol+ ),+ HandshakeType (+ ..,+ HandshakeType_HelloRequest,+ HandshakeType_ClientHello,+ HandshakeType_ServerHello,+ HandshakeType_NewSessionTicket,+ HandshakeType_EndOfEarlyData,+ HandshakeType_EncryptedExtensions,+ HandshakeType_Certificate,+ HandshakeType_ServerKeyXchg,+ HandshakeType_CertRequest,+ HandshakeType_ServerHelloDone,+ HandshakeType_CertVerify,+ HandshakeType_ClientKeyXchg,+ HandshakeType_Finished,+ HandshakeType_KeyUpdate,+ HandshakeType_CompressedCertificate+ ),+ CertificateChain_ (..),+ emptyCertificateChain_,+ Handshake (..),+ packetType,+ typeOfHandshake,+ module Network.TLS.HashAndSignature,+ ExtensionRaw (..),+ ExtensionID (..),+ showCertificateChain,+ isHelloRetryRequest,+ hrrRandom,+ ClientHello (..),+ ServerHello (..),+ HandshakeR,+) where++import Data.X509 (+ CertificateChain (..),+ DistinguishedName,+ certSubjectDN,+ getCharacterStringRawData,+ getDistinguishedElements,+ getSigned,+ signedObject,+ )+ import Network.TLS.Crypto-import Network.TLS.Util.Serialization+import Network.TLS.Error+import {-# SOURCE #-} Network.TLS.Extension+import Network.TLS.HashAndSignature import Network.TLS.Imports+import Network.TLS.Types -data ConnectionEnd = ConnectionServer | ConnectionClient-data CipherType = CipherStream | CipherBlock | CipherAEAD+---------------------------------------------------------------- data CipherData = CipherData { cipherDataContent :: ByteString- , cipherDataMAC :: Maybe ByteString+ , cipherDataMAC :: Maybe ByteString , cipherDataPadding :: Maybe (ByteString, Int)- } deriving (Show,Eq)+ }+ deriving (Show, Eq) +----------------------------------------------------------------+ -- | Some of the IANA registered code points for 'CertificateType' are not -- currently supported by the library. Nor should they be, they're are either -- unwise, obsolete or both. There's no point in conveying these to the user@@ -83,586 +156,346 @@ -- filtered to exclude unsupported values. If the user cannot find a certificate -- for a supported code point, we'll go ahead without a client certificate and -- hope for the best, unless the user's callback decides to throw an exception.----data CertificateType =- CertificateType_RSA_Sign -- ^ TLS10 and up, RFC5246- | CertificateType_DSS_Sign -- ^ TLS10 and up, RFC5246- | CertificateType_ECDSA_Sign -- ^ TLS10 and up, RFC8422- | CertificateType_Ed25519_Sign -- ^ TLS13 and up, synthetic- | CertificateType_Ed448_Sign -- ^ TLS13 and up, synthetic- -- | None of the below will ever be presented to the callback. Any future- -- public key algorithms valid for client certificates go above this line.- | CertificateType_RSA_Fixed_DH -- Obsolete, unsupported- | CertificateType_DSS_Fixed_DH -- Obsolete, unsupported- | CertificateType_RSA_Ephemeral_DH -- Obsolete, unsupported- | CertificateType_DSS_Ephemeral_DH -- Obsolete, unsupported- | CertificateType_fortezza_dms -- Obsolete, unsupported- | CertificateType_RSA_Fixed_ECDH -- Obsolete, unsupported- | CertificateType_ECDSA_Fixed_ECDH -- Obsolete, unsupported- | CertificateType_Unknown Word8 -- Obsolete, unsupported- deriving (Eq, Ord, Show)+newtype CertificateType = CertificateType {fromCertificateType :: Word8}+ deriving (Eq, Ord) +{- FOURMOLU_DISABLE -}+-- | TLS10 and up, RFC5246+pattern CertificateType_RSA_Sign :: CertificateType+pattern CertificateType_RSA_Sign = CertificateType 1+-- | TLS10 and up, RFC5246+pattern CertificateType_DSA_Sign :: CertificateType+pattern CertificateType_DSA_Sign = CertificateType 2+-- | TLS10 and up, RFC8422+pattern CertificateType_ECDSA_Sign :: CertificateType+pattern CertificateType_ECDSA_Sign = CertificateType 64+-- \| There are no code points that map to the below synthetic types, these+-- are inferred indirectly from the @signature_algorithms@ extension of the+-- TLS 1.3 @CertificateRequest@ message. the value assignments are there+-- only to avoid partial function warnings.+pattern CertificateType_Ed25519_Sign :: CertificateType+pattern CertificateType_Ed25519_Sign = CertificateType 254 -- fixme: dummy value+pattern CertificateType_Ed448_Sign :: CertificateType+pattern CertificateType_Ed448_Sign = CertificateType 255 -- fixme: dummy value++instance Show CertificateType where+ 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 -}+ -- | Last supported certificate type, no 'CertificateType that -- compares greater than this one (based on the 'Ord' instance, -- not on the wire code point) will be reported to the application -- via the client certificate request callback.--- lastSupportedCertificateType :: CertificateType lastSupportedCertificateType = CertificateType_ECDSA_Sign +------------------------------------------------------------ -data HashAlgorithm =- HashNone- | HashMD5- | HashSHA1- | HashSHA224- | HashSHA256- | HashSHA384- | HashSHA512- | HashIntrinsic- | HashOther Word8- deriving (Show,Eq)+type Signature = ByteString -data SignatureAlgorithm =- SignatureAnonymous- | SignatureRSA- | SignatureDSS- | SignatureECDSA- | SignatureRSApssRSAeSHA256- | SignatureRSApssRSAeSHA384- | SignatureRSApssRSAeSHA512- | SignatureEd25519- | SignatureEd448- | SignatureRSApsspssSHA256- | SignatureRSApsspssSHA384- | SignatureRSApsspssSHA512- | SignatureOther Word8- deriving (Show,Eq)+data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature+ deriving (Eq) -type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm)+instance Show DigitallySigned where+ show (DigitallySigned hs _sig) = "DigitallySigned " ++ show hs ++ " \"...\"" -------------------------------------------------------------+---------------------------------------------------------------- -type Signature = ByteString+newtype ProtocolType = ProtocolType {fromProtocolType :: Word8} deriving (Eq) -data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature- deriving (Show,Eq)+{- FOURMOLU_DISABLE -}+pattern ProtocolType_ChangeCipherSpec :: ProtocolType+pattern ProtocolType_ChangeCipherSpec = ProtocolType 20 -data ProtocolType =- ProtocolType_ChangeCipherSpec- | ProtocolType_Alert- | ProtocolType_Handshake- | ProtocolType_AppData- | ProtocolType_DeprecatedHandshake- deriving (Eq, Show)+pattern ProtocolType_Alert :: ProtocolType+pattern ProtocolType_Alert = ProtocolType 21 --- | TLSError that might be returned through the TLS stack-data TLSError =- Error_Misc String -- ^ mainly for instance of Error- | Error_Protocol (String, Bool, AlertDescription)- | Error_Certificate String- | Error_HandshakePolicy String -- ^ handshake policy failed.- | Error_EOF- | Error_Packet String- | Error_Packet_unexpected String String- | Error_Packet_Parsing String- deriving (Eq, Show, Typeable)+pattern ProtocolType_Handshake :: ProtocolType+pattern ProtocolType_Handshake = ProtocolType 22 -instance Exception TLSError+pattern ProtocolType_AppData :: ProtocolType+pattern ProtocolType_AppData = ProtocolType 23 --- | TLS Exceptions related to bad user usage or--- asynchronous errors-data TLSException =- Terminated Bool String TLSError -- ^ Early termination exception with the reason- -- and the error associated- | HandshakeFailed TLSError -- ^ Handshake failed for the reason attached- | ConnectionNotEstablished -- ^ Usage error when the connection has not been established- -- and the user is trying to send or receive data- deriving (Show,Eq,Typeable)+instance Show ProtocolType where+ show ProtocolType_ChangeCipherSpec = "ChangeCipherSpec"+ show ProtocolType_Alert = "Alert"+ show ProtocolType_Handshake = "Handshake"+ show ProtocolType_AppData = "AppData"+ show (ProtocolType x) = "ProtocolType " ++ show x+{- FOURMOLU_ENABLE -} -instance Exception TLSException+---------------------------------------------------------------- -data Packet =- Handshake [Handshake]+data Packet+ = Handshake [Handshake] [WireBytes] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString- deriving (Show,Eq)+ deriving (Eq) -data Header = Header ProtocolType Version Word16 deriving (Show,Eq)+instance Show Packet where+ show (Handshake hs _) = "Handshake " ++ show hs+ show (Alert as) = "Alert " ++ show as+ show ChangeCipherSpec = "ChangeCipherSpec"+ show (AppData bs) = "AppData " ++ showBytesHex bs -newtype ServerRandom = ServerRandom { unServerRandom :: ByteString } deriving (Show, Eq)-newtype ClientRandom = ClientRandom { unClientRandom :: ByteString } deriving (Show, Eq)-newtype Session = Session (Maybe SessionID) deriving (Show, Eq)+data Header = Header ProtocolType Version Word16 deriving (Show, Eq) -type FinishedData = ByteString+newtype ServerRandom = ServerRandom {unServerRandom :: ByteString}+ deriving (Eq)+instance Show ServerRandom where+ show sr@(ServerRandom bs)+ | isHelloRetryRequest sr = "HelloRetryReqest"+ | otherwise = "ServerRandom " ++ showBytesHex bs --- | Identifier of a TLS extension.-type ExtensionID = Word16+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" --- | The raw content of a TLS extension.-data ExtensionRaw = ExtensionRaw ExtensionID ByteString+isHelloRetryRequest :: ServerRandom -> Bool+isHelloRetryRequest = (== hrrRandom)++newtype ClientRandom = ClientRandom {unClientRandom :: ByteString} deriving (Eq) -instance Show ExtensionRaw where- show (ExtensionRaw eid bs) = "ExtensionRaw " ++ showEID eid ++ " " ++ showBytesHex bs+instance Show ClientRandom where+ show (ClientRandom bs) = "ClientRandom " ++ showBytesHex bs -showEID :: ExtensionID -> String-showEID 0x0 = "ServerName"-showEID 0x1 = "MaxFragmentLength"-showEID 0x2 = "ClientCertificateUrl"-showEID 0x3 = "TrustedCAKeys"-showEID 0x4 = "TruncatedHMAC"-showEID 0x5 = "StatusRequest"-showEID 0x6 = "UserMapping"-showEID 0x7 = "ClientAuthz"-showEID 0x8 = "ServerAuthz"-showEID 0x9 = "CertType"-showEID 0xa = "NegotiatedGroups"-showEID 0xb = "EcPointFormats"-showEID 0xc = "SRP"-showEID 0xd = "SignatureAlgorithm"-showEID 0xe = "SRTP"-showEID 0xf = "Heartbeat"-showEID 0x10 = "ApplicationLayerProtocolNegotiation"-showEID 0x11 = "StatusRequestv2"-showEID 0x12 = "SignedCertificateTimestamp"-showEID 0x13 = "ClientCertificateType"-showEID 0x14 = "ServerCertificateType"-showEID 0x15 = "Padding"-showEID 0x16 = "EncryptThenMAC"-showEID 0x17 = "ExtendedMasterSecret"-showEID 0x23 = "SessionTicket"-showEID 0x29 = "PreShardeKey"-showEID 0x2a = "EarlyData"-showEID 0x2b = "SupportedVersions"-showEID 0x2c = "Cookie"-showEID 0x2d = "PskKeyExchangeModes"-showEID 0x2f = "CertificateAuthorities"-showEID 0x30 = "OidFilters"-showEID 0x31 = "PostHandshakeAuth"-showEID 0x32 = "SignatureAlgorithmsCert"-showEID 0x33 = "KeyShare"-showEID 0x39 = "QuicTransportParameters"-showEID 0xff01 = "SecureRenegotiation"-showEID 0xffa5 = "QuicTransportParameters"-showEID x = show x+newtype Session = Session (Maybe SessionID) deriving (Eq)+instance Show Session where+ show (Session Nothing) = "Session \"\""+ show (Session (Just bs)) = "Session " ++ showBytesHex bs -data AlertLevel =- AlertLevel_Warning- | AlertLevel_Fatal- deriving (Show,Eq)+{-# DEPRECATED FinishedData "use VerifyData" #-}+type FinishedData = ByteString -data AlertDescription =- CloseNotify- | UnexpectedMessage- | BadRecordMac- | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation- | RecordOverflow- | DecompressionFailure- | HandshakeFailure- | BadCertificate- | UnsupportedCertificate- | CertificateRevoked- | CertificateExpired- | CertificateUnknown- | IllegalParameter- | UnknownCa- | AccessDenied- | DecodeError- | DecryptError- | ExportRestriction- | ProtocolVersion- | InsufficientSecurity- | InternalError- | InappropriateFallback -- RFC7507- | UserCanceled- | NoRenegotiation- | MissingExtension- | UnsupportedExtension- | CertificateUnobtainable- | UnrecognizedName- | BadCertificateStatusResponse- | BadCertificateHashValue- | UnknownPskIdentity- | CertificateRequired- | NoApplicationProtocol -- RFC7301- deriving (Show,Eq)+newtype VerifyData = VerifyData ByteString deriving (Eq)+instance Show VerifyData where+ show (VerifyData bs) = showBytesHex bs -data HandshakeType =- HandshakeType_HelloRequest- | HandshakeType_ClientHello- | HandshakeType_ServerHello- | HandshakeType_Certificate- | HandshakeType_ServerKeyXchg- | HandshakeType_CertRequest- | HandshakeType_ServerHelloDone- | HandshakeType_CertVerify- | HandshakeType_ClientKeyXchg- | HandshakeType_Finished- deriving (Show,Eq)+---------------------------------------------------------------- -newtype BigNum = BigNum ByteString- deriving (Show,Eq)+newtype HandshakeType = HandshakeType {fromHandshakeType :: Word8}+ deriving (Eq) -bigNumToInteger :: BigNum -> Integer-bigNumToInteger (BigNum b) = os2ip b+{- 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_CompressedCertificate :: HandshakeType+pattern HandshakeType_CompressedCertificate = HandshakeType 25 -bigNumFromInteger :: Integer -> BigNum-bigNumFromInteger i = BigNum $ i2osp i+instance Show HandshakeType where+ 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 -} +----------------------------------------------------------------+ data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum , serverDHParams_y :: BigNum- } deriving (Show,Eq)+ }+ deriving (Show, Eq) serverDHParamsFrom :: DHParams -> DHPublic -> ServerDHParams serverDHParamsFrom params dhPub =- ServerDHParams (bigNumFromInteger $ dhParamsGetP params)- (bigNumFromInteger $ dhParamsGetG params)- (bigNumFromInteger $ dhUnwrapPublic dhPub)+ ServerDHParams+ (bigNumFromInteger $ dhParamsGetP params)+ (bigNumFromInteger $ dhParamsGetG params)+ (bigNumFromInteger $ dhUnwrapPublic dhPub) serverDHParamsToParams :: ServerDHParams -> DHParams serverDHParamsToParams serverParams =- dhParams (bigNumToInteger $ serverDHParams_p serverParams)- (bigNumToInteger $ serverDHParams_g serverParams)+ dhParams+ (bigNumToInteger $ serverDHParams_p serverParams)+ (bigNumToInteger $ serverDHParams_g serverParams) serverDHParamsToPublic :: ServerDHParams -> DHPublic serverDHParamsToPublic serverParams = dhPublic (bigNumToInteger $ serverDHParams_y serverParams) -data ServerECDHParams = ServerECDHParams Group GroupPublic- deriving (Show,Eq)+---------------------------------------------------------------- +data ServerECDHParams = ServerECDHParams Group GroupPublicA+ deriving (Show, Eq)++----------------------------------------------------------------+ data ServerRSAParams = ServerRSAParams- { rsa_modulus :: Integer+ { rsa_modulus :: Integer , rsa_exponent :: Integer- } deriving (Show,Eq)+ }+ deriving (Show, Eq) -data ServerKeyXchgAlgorithmData =- SKX_DH_Anon ServerDHParams- | SKX_DHE_DSS ServerDHParams DigitallySigned+----------------------------------------------------------------++data ServerDSAParams = ServerDSAParams deriving (Show, Eq)++----------------------------------------------------------------++data ServerKeyXchgAlgorithmData+ = SKX_DH_Anon ServerDHParams+ | SKX_DHE_DSA ServerDHParams DigitallySigned | SKX_DHE_RSA ServerDHParams DigitallySigned | SKX_ECDHE_RSA ServerECDHParams DigitallySigned | SKX_ECDHE_ECDSA ServerECDHParams DigitallySigned | SKX_RSA (Maybe ServerRSAParams)- | SKX_DH_DSS (Maybe ServerRSAParams)+ | SKX_DH_DSA (Maybe ServerDSAParams) | 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) -data ClientKeyXchgAlgorithmData =- CKX_RSA ByteString+{- 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) -type DeprecatedRecord = ByteString+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 Handshake =- ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord)- | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw]- | Certificates CertificateChain+----------------------------------------------------------------++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 (Eq, Show)++data ServerHello = SH+ { shVersion :: Version+ , shRandom :: ServerRandom+ , shSession :: Session+ , shCipher :: CipherId+ , shComp :: CompressionID+ , shExtensions :: [ExtensionRaw]+ }+ deriving (Eq, Show)++data Handshake+ = ClientHello ClientHello+ | ServerHello ServerHello+ | Certificate CertificateChain_ | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData | ServerKeyXchg ServerKeyXchgAlgorithmData- | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName]+ | CertRequest+ [CertificateType]+ [HashAndSignatureAlgorithm]+ [DistinguishedName] | CertVerify DigitallySigned- | Finished FinishedData- deriving (Show,Eq)+ | Finished VerifyData+ | NewSessionTicket Second Ticket+ deriving (Show, Eq) +{- 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 typeOfHandshake :: Handshake -> HandshakeType-typeOfHandshake ClientHello{} = HandshakeType_ClientHello-typeOfHandshake ServerHello{} = HandshakeType_ServerHello-typeOfHandshake Certificates{} = HandshakeType_Certificate-typeOfHandshake HelloRequest = HandshakeType_HelloRequest-typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone-typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg-typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg-typeOfHandshake CertRequest{} = HandshakeType_CertRequest-typeOfHandshake CertVerify{} = HandshakeType_CertVerify-typeOfHandshake Finished{} = HandshakeType_Finished--numericalVer :: Version -> (Word8, Word8)-numericalVer SSL2 = (2, 0)-numericalVer SSL3 = (3, 0)-numericalVer TLS10 = (3, 1)-numericalVer TLS11 = (3, 2)-numericalVer TLS12 = (3, 3)-numericalVer TLS13 = (3, 4)--verOfNum :: (Word8, Word8) -> Maybe Version-verOfNum (2, 0) = Just SSL2-verOfNum (3, 0) = Just SSL3-verOfNum (3, 1) = Just TLS10-verOfNum (3, 2) = Just TLS11-verOfNum (3, 3) = Just TLS12-verOfNum (3, 4) = Just TLS13-verOfNum _ = Nothing--class TypeValuable a where- valOfType :: a -> Word8- valToType :: Word8 -> Maybe a---- a better name for TypeValuable-class EnumSafe8 a where- fromEnumSafe8 :: a -> Word8- toEnumSafe8 :: Word8 -> Maybe a--class EnumSafe16 a where- fromEnumSafe16 :: a -> Word16- toEnumSafe16 :: Word16 -> Maybe a--instance TypeValuable ConnectionEnd where- valOfType ConnectionServer = 0- valOfType ConnectionClient = 1-- valToType 0 = Just ConnectionServer- valToType 1 = Just ConnectionClient- valToType _ = Nothing--instance TypeValuable CipherType where- valOfType CipherStream = 0- valOfType CipherBlock = 1- valOfType CipherAEAD = 2-- valToType 0 = Just CipherStream- valToType 1 = Just CipherBlock- valToType 2 = Just CipherAEAD- valToType _ = Nothing--instance TypeValuable ProtocolType where- valOfType ProtocolType_ChangeCipherSpec = 20- valOfType ProtocolType_Alert = 21- valOfType ProtocolType_Handshake = 22- valOfType ProtocolType_AppData = 23- valOfType ProtocolType_DeprecatedHandshake = 128 -- unused-- valToType 20 = Just ProtocolType_ChangeCipherSpec- valToType 21 = Just ProtocolType_Alert- valToType 22 = Just ProtocolType_Handshake- valToType 23 = Just ProtocolType_AppData- valToType _ = Nothing--instance TypeValuable HandshakeType where- valOfType HandshakeType_HelloRequest = 0- valOfType HandshakeType_ClientHello = 1- valOfType HandshakeType_ServerHello = 2- valOfType HandshakeType_Certificate = 11- valOfType HandshakeType_ServerKeyXchg = 12- valOfType HandshakeType_CertRequest = 13- valOfType HandshakeType_ServerHelloDone = 14- valOfType HandshakeType_CertVerify = 15- valOfType HandshakeType_ClientKeyXchg = 16- valOfType HandshakeType_Finished = 20-- valToType 0 = Just HandshakeType_HelloRequest- valToType 1 = Just HandshakeType_ClientHello- valToType 2 = Just HandshakeType_ServerHello- valToType 11 = Just HandshakeType_Certificate- valToType 12 = Just HandshakeType_ServerKeyXchg- valToType 13 = Just HandshakeType_CertRequest- valToType 14 = Just HandshakeType_ServerHelloDone- valToType 15 = Just HandshakeType_CertVerify- valToType 16 = Just HandshakeType_ClientKeyXchg- valToType 20 = Just HandshakeType_Finished- valToType _ = Nothing--instance TypeValuable AlertLevel where- valOfType AlertLevel_Warning = 1- valOfType AlertLevel_Fatal = 2-- valToType 1 = Just AlertLevel_Warning- valToType 2 = Just AlertLevel_Fatal- valToType _ = Nothing--instance TypeValuable AlertDescription where- valOfType CloseNotify = 0- valOfType UnexpectedMessage = 10- valOfType BadRecordMac = 20- valOfType DecryptionFailed = 21- valOfType RecordOverflow = 22- valOfType DecompressionFailure = 30- valOfType HandshakeFailure = 40- valOfType BadCertificate = 42- valOfType UnsupportedCertificate = 43- valOfType CertificateRevoked = 44- valOfType CertificateExpired = 45- valOfType CertificateUnknown = 46- valOfType IllegalParameter = 47- valOfType UnknownCa = 48- valOfType AccessDenied = 49- valOfType DecodeError = 50- valOfType DecryptError = 51- valOfType ExportRestriction = 60- valOfType ProtocolVersion = 70- valOfType InsufficientSecurity = 71- valOfType InternalError = 80- valOfType InappropriateFallback = 86- valOfType UserCanceled = 90- valOfType NoRenegotiation = 100- valOfType MissingExtension = 109- valOfType UnsupportedExtension = 110- valOfType CertificateUnobtainable = 111- valOfType UnrecognizedName = 112- valOfType BadCertificateStatusResponse = 113- valOfType BadCertificateHashValue = 114- valOfType UnknownPskIdentity = 115- valOfType CertificateRequired = 116- valOfType NoApplicationProtocol = 120-- valToType 0 = Just CloseNotify- valToType 10 = Just UnexpectedMessage- valToType 20 = Just BadRecordMac- valToType 21 = Just DecryptionFailed- valToType 22 = Just RecordOverflow- valToType 30 = Just DecompressionFailure- valToType 40 = Just HandshakeFailure- valToType 42 = Just BadCertificate- valToType 43 = Just UnsupportedCertificate- valToType 44 = Just CertificateRevoked- valToType 45 = Just CertificateExpired- valToType 46 = Just CertificateUnknown- valToType 47 = Just IllegalParameter- valToType 48 = Just UnknownCa- valToType 49 = Just AccessDenied- valToType 50 = Just DecodeError- valToType 51 = Just DecryptError- valToType 60 = Just ExportRestriction- valToType 70 = Just ProtocolVersion- valToType 71 = Just InsufficientSecurity- valToType 80 = Just InternalError- valToType 86 = Just InappropriateFallback- valToType 90 = Just UserCanceled- valToType 100 = Just NoRenegotiation- valToType 109 = Just MissingExtension- valToType 110 = Just UnsupportedExtension- valToType 111 = Just CertificateUnobtainable- valToType 112 = Just UnrecognizedName- valToType 113 = Just BadCertificateStatusResponse- valToType 114 = Just BadCertificateHashValue- valToType 115 = Just UnknownPskIdentity- valToType 116 = Just CertificateRequired- valToType 120 = Just NoApplicationProtocol- valToType _ = Nothing--instance TypeValuable CertificateType where- valOfType CertificateType_RSA_Sign = 1- valOfType CertificateType_ECDSA_Sign = 64- valOfType CertificateType_DSS_Sign = 2- valOfType CertificateType_RSA_Fixed_DH = 3- valOfType CertificateType_DSS_Fixed_DH = 4- valOfType CertificateType_RSA_Ephemeral_DH = 5- valOfType CertificateType_DSS_Ephemeral_DH = 6- valOfType CertificateType_fortezza_dms = 20- valOfType CertificateType_RSA_Fixed_ECDH = 65- valOfType CertificateType_ECDSA_Fixed_ECDH = 66- valOfType (CertificateType_Unknown i) = i- -- | There are no code points that map to the below synthetic types, these- -- are inferred indirectly from the @signature_algorithms@ extension of the- -- TLS 1.3 @CertificateRequest@ message. the value assignments are there- -- only to avoid partial function warnings.- valOfType CertificateType_Ed25519_Sign = 0- valOfType CertificateType_Ed448_Sign = 0-- valToType 1 = Just CertificateType_RSA_Sign- valToType 2 = Just CertificateType_DSS_Sign- valToType 3 = Just CertificateType_RSA_Fixed_DH- valToType 4 = Just CertificateType_DSS_Fixed_DH- valToType 5 = Just CertificateType_RSA_Ephemeral_DH- valToType 6 = Just CertificateType_DSS_Ephemeral_DH- valToType 20 = Just CertificateType_fortezza_dms- valToType 64 = Just CertificateType_ECDSA_Sign- valToType 65 = Just CertificateType_RSA_Fixed_ECDH- valToType 66 = Just CertificateType_ECDSA_Fixed_ECDH- valToType i = Just (CertificateType_Unknown i)- -- | There are no code points that map to the below synthetic types, these- -- are inferred indirectly from the @signature_algorithms@ extension of the- -- TLS 1.3 @CertificateRequest@ message.- -- @- -- CertificateType_Ed25519_Sign- -- CertificateType_Ed448_Sign- -- @--instance TypeValuable HashAlgorithm where- valOfType HashNone = 0- valOfType HashMD5 = 1- valOfType HashSHA1 = 2- valOfType HashSHA224 = 3- valOfType HashSHA256 = 4- valOfType HashSHA384 = 5- valOfType HashSHA512 = 6- valOfType HashIntrinsic = 8- valOfType (HashOther i) = i-- valToType 0 = Just HashNone- valToType 1 = Just HashMD5- valToType 2 = Just HashSHA1- valToType 3 = Just HashSHA224- valToType 4 = Just HashSHA256- valToType 5 = Just HashSHA384- valToType 6 = Just HashSHA512- valToType 8 = Just HashIntrinsic- valToType i = Just (HashOther i)--instance TypeValuable SignatureAlgorithm where- valOfType SignatureAnonymous = 0- valOfType SignatureRSA = 1- valOfType SignatureDSS = 2- valOfType SignatureECDSA = 3- valOfType SignatureRSApssRSAeSHA256 = 4- valOfType SignatureRSApssRSAeSHA384 = 5- valOfType SignatureRSApssRSAeSHA512 = 6- valOfType SignatureEd25519 = 7- valOfType SignatureEd448 = 8- valOfType SignatureRSApsspssSHA256 = 9- valOfType SignatureRSApsspssSHA384 = 10- valOfType SignatureRSApsspssSHA512 = 11- valOfType (SignatureOther i) = i-- valToType 0 = Just SignatureAnonymous- valToType 1 = Just SignatureRSA- valToType 2 = Just SignatureDSS- valToType 3 = Just SignatureECDSA- valToType 4 = Just SignatureRSApssRSAeSHA256- valToType 5 = Just SignatureRSApssRSAeSHA384- valToType 6 = Just SignatureRSApssRSAeSHA512- valToType 7 = Just SignatureEd25519- valToType 8 = Just SignatureEd448- valToType 9 = Just SignatureRSApsspssSHA256- valToType 10 = Just SignatureRSApsspssSHA384- valToType 11 = Just SignatureRSApsspssSHA512- valToType i = Just (SignatureOther i)--instance EnumSafe16 Group where- fromEnumSafe16 P256 = 23- fromEnumSafe16 P384 = 24- fromEnumSafe16 P521 = 25- fromEnumSafe16 X25519 = 29- fromEnumSafe16 X448 = 30- fromEnumSafe16 FFDHE2048 = 256- fromEnumSafe16 FFDHE3072 = 257- fromEnumSafe16 FFDHE4096 = 258- fromEnumSafe16 FFDHE6144 = 259- fromEnumSafe16 FFDHE8192 = 260+typeOfHandshake ClientHello{} = HandshakeType_ClientHello+typeOfHandshake ServerHello{} = HandshakeType_ServerHello+typeOfHandshake Certificate{} = HandshakeType_Certificate+typeOfHandshake HelloRequest = HandshakeType_HelloRequest+typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone+typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg+typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg+typeOfHandshake CertRequest{} = HandshakeType_CertRequest+typeOfHandshake CertVerify{} = HandshakeType_CertVerify+typeOfHandshake Finished{} = HandshakeType_Finished+typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket+{- FOURMOLU_ENABLE -} - toEnumSafe16 23 = Just P256- toEnumSafe16 24 = Just P384- toEnumSafe16 25 = Just P521- toEnumSafe16 29 = Just X25519- toEnumSafe16 30 = Just X448- toEnumSafe16 256 = Just FFDHE2048- toEnumSafe16 257 = Just FFDHE3072- toEnumSafe16 258 = Just FFDHE4096- toEnumSafe16 259 = Just FFDHE6144- toEnumSafe16 260 = Just FFDHE8192- toEnumSafe16 _ = Nothing+type HandshakeR = (Handshake, WireBytes)
Network/TLS/Struct13.hs view
@@ -1,102 +1,81 @@--- |--- Module : Network.TLS.Struct13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Struct13- ( Packet13(..)- , Handshake13(..)- , HandshakeType13(..)- , typeOfHandshake13- , contentType- , KeyUpdate(..)- ) where+module Network.TLS.Struct13 (+ Packet13 (..),+ Handshake13 (..),+ 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-import Network.TLS.Imports -data Packet13 =- Handshake13 [Handshake13]+data Packet13+ = Handshake13 [Handshake13] [WireBytes] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString- deriving (Show,Eq)+ deriving (Show, Eq) -data KeyUpdate = UpdateNotRequested- | UpdateRequested- deriving (Show,Eq)+data KeyUpdate+ = UpdateNotRequested+ | 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 =- ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw]- | ServerHello13 !ServerRandom !Session !CipherID [ExtensionRaw]- | NewSessionTicket13 Second Word32 TicketNonce SessionID [ExtensionRaw]+data Handshake13+ = 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- | Finished13 FinishedData+ | CertVerify13 DigitallySigned+ | Finished13 VerifyData | KeyUpdate13 KeyUpdate- deriving (Show,Eq)--data HandshakeType13 =- HandshakeType_ClientHello13- | HandshakeType_ServerHello13- | HandshakeType_EndOfEarlyData13- | HandshakeType_NewSessionTicket13- | HandshakeType_EncryptedExtensions13- | HandshakeType_CertRequest13- | HandshakeType_Certificate13- | HandshakeType_CertVerify13- | HandshakeType_Finished13- | HandshakeType_KeyUpdate13- deriving (Show,Eq)--typeOfHandshake13 :: Handshake13 -> HandshakeType13-typeOfHandshake13 ClientHello13{} = HandshakeType_ClientHello13-typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello13-typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData13-typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket13-typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions13-typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest13-typeOfHandshake13 Certificate13{} = HandshakeType_Certificate13-typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify13-typeOfHandshake13 Finished13{} = HandshakeType_Finished13-typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate13+ | CompressedCertificate13 CertReqContext CertificateChain_ [[ExtensionRaw]]+ deriving (Show, Eq) -instance TypeValuable HandshakeType13 where- valOfType HandshakeType_ClientHello13 = 1- valOfType HandshakeType_ServerHello13 = 2- valOfType HandshakeType_NewSessionTicket13 = 4- valOfType HandshakeType_EndOfEarlyData13 = 5- valOfType HandshakeType_EncryptedExtensions13 = 8- valOfType HandshakeType_CertRequest13 = 13- valOfType HandshakeType_Certificate13 = 11- valOfType HandshakeType_CertVerify13 = 15- valOfType HandshakeType_Finished13 = 20- valOfType HandshakeType_KeyUpdate13 = 24+-- | Certificate request context for TLS 1.3.+type CertReqContext = ByteString - valToType 1 = Just HandshakeType_ClientHello13- valToType 2 = Just HandshakeType_ServerHello13- valToType 4 = Just HandshakeType_NewSessionTicket13- valToType 5 = Just HandshakeType_EndOfEarlyData13- valToType 8 = Just HandshakeType_EncryptedExtensions13- valToType 13 = Just HandshakeType_CertRequest13- valToType 11 = Just HandshakeType_Certificate13- valToType 15 = Just HandshakeType_CertVerify13- valToType 20 = Just HandshakeType_Finished13- valToType 24 = Just HandshakeType_KeyUpdate13- valToType _ = Nothing+{- FOURMOLU_DISABLE -}+typeOfHandshake13 :: Handshake13 -> HandshakeType+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-contentType (Handshake13 _) = ProtocolType_Handshake-contentType (Alert13 _) = ProtocolType_Alert-contentType (AppData13 _) = ProtocolType_AppData+contentType Handshake13{} = ProtocolType_Handshake+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,137 +1,71 @@-{-# LANGUAGE EmptyDataDecls #-}--- |--- Module : Network.TLS.Types--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Types- ( Version(..)- , SessionID- , SessionData(..)- , SessionFlag(..)- , CertReqContext- , TLS13TicketInfo(..)- , CipherID- , CompressionID- , Role(..)- , invertRole- , Direction(..)- , HostName- , Second- , Millisecond- , EarlySecret- , HandshakeSecret- , ApplicationSecret- , ResumptionSecret- , BaseSecret(..)- , AnyTrafficSecret(..)- , ClientTrafficSecret(..)- , ServerTrafficSecret(..)- , TrafficSecrets- , SecretTriple(..)- , SecretPair(..)- , MasterSecret(..)- ) where--import Network.TLS.Imports-import Network.TLS.Crypto.Types (Group)--type HostName = String-type Second = Word32-type Millisecond = Word64---- | Versions known to TLS------ SSL2 is just defined, but this version is and will not be supported.-data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 | TLS13 deriving (Show, Eq, Ord, Bounded)---- | A session ID-type SessionID = ByteString---- | 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]- } deriving (Show,Eq)---- | Some session flags-data SessionFlag- = SessionEMS -- ^ Session created with Extended Master Secret- deriving (Show,Eq,Enum)---- | Certificate request context for TLS 1.3.-type CertReqContext = ByteString+module Network.TLS.Types (+ module Network.TLS.Types.Cipher,+ module Network.TLS.Types.Secret,+ module Network.TLS.Types.Session,+ module Network.TLS.Types.Version,+ HostName,+ Role (..),+ invertRole,+ Direction (..),+ BigNum (..),+ bigNumToInteger,+ bigNumFromInteger,+ defaultRecordSizeLimit,+ TranscriptHash (..),+ WireBytes,+) where -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)+import Network.Socket (HostName) --- | 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)+ 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- }+-- 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)+newtype TranscriptHash = TranscriptHash ByteString --- Master secret for TLS 1.2 or earlier.-newtype MasterSecret = MasterSecret ByteString deriving Show+instance Show TranscriptHash where+ show (TranscriptHash bs) = showBytesHex bs++----------------------------------------------------------------++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,62 @@+module Network.TLS.Types.Secret where++import Data.ByteArray (convert)+import Network.TLS.Imports+import Network.TLS.Types.Cipher++-- | Phantom type indicating early traffic secret.+data EarlySecret++-- | 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 (BaseSecret bs) = showBytesHex $ convert bs++newtype AnyTrafficSecret a = AnyTrafficSecret Secret++instance Show (AnyTrafficSecret a) where+ show (AnyTrafficSecret bs) = showBytesHex $ convert bs++-- | A client traffic secret, typed with a parameter indicating a step in the+-- TLS key schedule.+newtype ClientTrafficSecret a = ClientTrafficSecret Secret++instance Show (ClientTrafficSecret a) where+ show (ClientTrafficSecret bs) = showBytesHex $ convert bs++-- | A server traffic secret, typed with a parameter indicating a step in the+-- TLS key schedule.+newtype ServerTrafficSecret a = ServerTrafficSecret Secret++instance Show (ServerTrafficSecret a) where+ show (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 (MainSecret bs) = showBytesHex $ convert bs
+ Network/TLS/Types/Session.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveGeneric #-}++module Network.TLS.Types.Session 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+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 (Show, Eq, Generic)++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,102 +1,115 @@ {-# LANGUAGE ScopedTypeVariables #-}-module Network.TLS.Util- ( sub- , takelast- , partition3- , partition6- , fromJust- , (&&!)- , bytesEq- , fmapEither- , catchException- , forEitherM- , mapChunks_- , getChunks- , Saved- , saveMVar- , restoreMVar- ) where+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Network.TLS.Util (+ sub,+ takelast,+ partition3,+ partition6,+ (&&!),+ fmapEither,+ catchException,+ forEitherM,+ mapChunks_,+ getChunks,+ Saved,+ saveMVar,+ restoreMVar,+) where++import Control.Concurrent.MVar+import Control.Exception (SomeAsyncException (..))+import qualified Control.Exception as E+import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import qualified Data.ByteString as B-import Network.TLS.Imports -import Control.Exception (SomeException)-import Control.Concurrent.Async-import Control.Concurrent.MVar+import Network.TLS.Imports sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len | B.length b < offset + len = Nothing- | otherwise = Just $ B.take len $ snd $ B.splitAt offset b+ | otherwise = Just $ B.take len $ snd $ B.splitAt offset b takelast :: Int -> ByteString -> Maybe ByteString takelast i b | B.length b >= i = sub b (B.length b - i) i- | otherwise = Nothing+ | otherwise = Nothing -partition3 :: ByteString -> (Int,Int,Int) -> Maybe (ByteString, ByteString, ByteString)-partition3 bytes (d1,d2,d3)- | any (< 0) l = Nothing+partition3+ :: ByteString -> (Int, Int, Int) -> Maybe (ByteString, ByteString, ByteString)+partition3 bytes (d1, d2, d3)+ | any (< 0) l = Nothing | sum l /= B.length bytes = Nothing- | otherwise = Just (p1,p2,p3)- where l = [d1,d2,d3]- (p1, r1) = B.splitAt d1 bytes- (p2, r2) = B.splitAt d2 r1- (p3, _) = B.splitAt d3 r2--partition6 :: ByteString -> (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)- 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+ | otherwise = Just (p1, p2, p3)+ where+ l = [d1, d2, d3]+ (p1, r1) = B.splitAt d1 bytes+ (p2, r2) = B.splitAt d2 r1+ (p3, _) = B.splitAt d3 r2 -fromJust :: String -> Maybe a -> a-fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck-fromJust _ (Just x) = x+partition6+ :: ScrubbedBytes+ -> (Int, Int, Int, Int, Int, Int)+ -> 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+ 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-True &&! True = True-True &&! False = False-False &&! True = False+True &&! True = True+True &&! False = False+False &&! True = False False &&! False = False --- | verify that 2 bytestrings are equals.--- it's a non lazy version, that will compare every bytes.--- arguments with different length will bail out early-bytesEq :: ByteString -> ByteString -> Bool-bytesEq = BA.constEq- 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 (SomeAsyncException _) -> Nothing+ Nothing -> Just e forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b])-forEitherM [] _ = return (pure [])-forEitherM (x:xs) f = f x >>= doTail+forEitherM [] _ = return (pure [])+forEitherM (x : xs) f = f x >>= doTail where doTail (Right b) = fmap (b :) <$> forEitherM xs f- doTail (Left e) = return (Left e)+ doTail (Left e) = return (Left e) -mapChunks_ :: Monad m- => Maybe Int -> (B.ByteString -> m a) -> B.ByteString -> m ()+mapChunks_+ :: Monad m+ => Maybe Int+ -> (ByteString -> m a)+ -> ByteString+ -> m () mapChunks_ len f = mapM_ f . getChunks len -getChunks :: Maybe Int -> B.ByteString -> [B.ByteString]-getChunks Nothing = (: [])+getChunks :: Maybe Int -> ByteString -> [ByteString]+getChunks Nothing = (: []) getChunks (Just len) = go where- go bs | B.length bs > len =- let (chunk, remain) = B.splitAt len bs- in chunk : go remain- | otherwise = [bs]+ go bs+ | B.length bs > len =+ let (chunk, remain) = B.splitAt len bs+ in chunk : go remain+ | otherwise = [bs] -- | An opaque newtype wrapper to prevent from poking inside content that has -- been saved.
Network/TLS/Util/ASN1.hs view
@@ -1,37 +1,32 @@--- |--- Module : Network.TLS.Util.ASN1--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ ASN1 utils for TLS----module Network.TLS.Util.ASN1- ( decodeASN1Object- , encodeASN1Object- ) where+-- | ASN1 utils for TLS+module Network.TLS.Util.ASN1 (+ decodeASN1Object,+ encodeASN1Object,+) where -import Network.TLS.Imports-import Data.ASN1.Types (fromASN1, toASN1, ASN1Object)+import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1', encodeASN1')-import Data.ASN1.BinaryEncoding (DER(..))+import Data.ASN1.Types (ASN1Object, fromASN1, toASN1) +import Network.TLS.Imports+ -- | Attempt to decode a bytestring representing -- an DER ASN.1 serialized object into the object.-decodeASN1Object :: ASN1Object a- => String- -> ByteString- -> Either String a+decodeASN1Object+ :: ASN1Object a+ => String+ -> ByteString+ -> Either String a decodeASN1Object name bs = case decodeASN1' DER bs of- Left e -> Left (name ++ ": cannot decode ASN1: " ++ show e)+ Left e -> Left (name ++ ": cannot decode ASN1: " ++ show e) Right asn1 -> case fromASN1 asn1 of- Left e -> Left (name ++ ": cannot parse ASN1: " ++ show e)- Right (d,_) -> Right d+ Left e -> Left (name ++ ": cannot parse ASN1: " ++ show e)+ Right (d, _) -> Right d -- | Encode an ASN.1 Object to the DER serialized bytestring-encodeASN1Object :: ASN1Object a- => a- -> ByteString+encodeASN1Object+ :: ASN1Object a+ => a+ -> ByteString encodeASN1Object obj = encodeASN1' DER $ toASN1 obj []
Network/TLS/Util/Serialization.hs view
@@ -1,7 +1,7 @@-module Network.TLS.Util.Serialization- ( os2ip- , i2osp- , i2ospOf_- ) where+module Network.TLS.Util.Serialization (+ os2ip,+ i2osp,+ i2ospOf_,+) where -import Crypto.Number.Serialize (os2ip, i2osp, i2ospOf_)+import Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip)
Network/TLS/Wire.hs view
@@ -1,87 +1,84 @@--- |--- Module : Network.TLS.Wire--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ the Wire module is a specialized marshalling/unmarshalling package related to the TLS protocol.--- all multibytes values are written as big endian.----module Network.TLS.Wire- ( Get- , GetResult(..)- , GetContinuation- , runGet- , runGetErr- , runGetMaybe- , tryGet- , remaining- , getWord8- , getWords8- , getWord16- , getWords16- , getWord24- , getWord32- , getWord64- , getBytes- , getOpaque8- , getOpaque16- , getOpaque24- , getInteger16- , getBigNum16- , getList- , processBytes- , isEmpty- , Put- , runPut- , putWord8- , putWords8- , putWord16- , putWords16- , putWord24- , putWord32- , putWord64- , putBytes- , putOpaque8- , putOpaque16- , putOpaque24- , putInteger16- , putBigNum16- , encodeWord16- , encodeWord32- , encodeWord64- ) where+-- | The Wire module is a specialized marshalling/unmarshalling+-- package related to the TLS protocol. All multibytes values are+-- written as big endian.+module Network.TLS.Wire (+ Get,+ GetResult (..),+ GetContinuation,+ runGet,+ runGetErr,+ runGetMaybe,+ tryGet,+ remaining,+ getWord8,+ getWords8,+ getWord16,+ getWords16,+ getWord24,+ getWord32,+ getWord64,+ getBytes,+ getOpaque8,+ getOpaque16,+ getOpaque24,+ getInteger16,+ getBigNum16,+ getList,+ processBytes,+ isEmpty,+ Put,+ runPut,+ putWord8,+ putWords8,+ putWord16,+ putWords16,+ putWord24,+ putWord32,+ putWord64,+ putBytes,+ putOpaque8,+ putOpaque16,+ putOpaque24,+ putInteger16,+ putBigNum16,+ encodeWord16,+ encodeWord32,+ encodeWord64,+) where +import qualified Data.ByteString as B import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put-import qualified Data.ByteString as B-import Network.TLS.Struct++import Network.TLS.Error import Network.TLS.Imports+import Network.TLS.Types import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a-data GetResult a =- GotError TLSError+data GetResult a+ = GotError TLSError | GotPartial (GetContinuation a) | GotSuccess a | GotSuccessRemaining a ByteString runGet :: String -> Get a -> ByteString -> GetResult a runGet lbl f = toGetResult <$> G.runGetPartial (label lbl f)- where toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err)- toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont)- toGetResult (G.Done r bsLeft)- | B.null bsLeft = GotSuccess r- | otherwise = GotSuccessRemaining r bsLeft+ where+ toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err)+ toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont)+ toGetResult (G.Done r bsLeft)+ | B.null bsLeft = GotSuccess r+ | otherwise = GotSuccessRemaining r bsLeft runGetErr :: String -> Get a -> ByteString -> Either TLSError a runGetErr lbl getter b = toSimple $ runGet lbl getter b- where toSimple (GotError err) = Left err- toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet"))- toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes"))- toSimple (GotSuccess r) = Right r+ where+ toSimple (GotError err) = Left err+ toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet"))+ toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes"))+ toSimple (GotSuccess r) = Right r runGetMaybe :: Get a -> ByteString -> Maybe a runGetMaybe f = either (const Nothing) Just . G.runGet f@@ -96,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@@ -128,10 +128,13 @@ getList :: Int -> Get (Int, a) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen)- where getElements len- | len < 0 = error "list consumed too much data. should never happen with isolate."- | len == 0 = return []- | otherwise = getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen)+ where+ getElements len+ | len < 0 =+ error "list consumed too much data. should never happen with isolate."+ | len == 0 = return []+ | otherwise =+ getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f@@ -160,7 +163,7 @@ let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff)- mapM_ putWord8 [a,b,c]+ mapM_ putWord8 [a, b, c] putBytes :: ByteString -> Put putBytes = putByteString
Network/TLS/X509.hs view
@@ -1,66 +1,82 @@--- |--- Module : Network.TLS.X509--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ X509 helpers----module Network.TLS.X509- ( CertificateChain(..)- , Certificate(..)- , SignedCertificate- , getCertificate- , isNullCertificateChain- , getCertificateChainLeaf- , CertificateRejectReason(..)- , CertificateUsage(..)- , CertificateStore- , ValidationCache- , exceptionValidationCache- , validateDefault- , FailedReason- , ServiceID- , wrapCertificateChecks- , pubkeyType- ) where+-- | X509 helpers+module Network.TLS.X509 (+ CertificateChain (..),+ Certificate (..),+ SignedCertificate,+ getCertificate,+ isNullCertificateChain,+ getCertificateChainLeaf,+ CertificateRejectReason (..),+ CertificateUsage (..),+ CertificateStore,+ ValidationCache,+ defaultValidationCache,+ exceptionValidationCache,+ validateDefault,+ FailedReason,+ ServiceID,+ wrapCertificateChecks,+ pubkeyType,+ validateClientCertificate,+) where import Data.X509-import Data.X509.Validation import Data.X509.CertificateStore+import Data.X509.Validation isNullCertificateChain :: CertificateChain -> Bool isNullCertificateChain (CertificateChain l) = null l getCertificateChainLeaf :: CertificateChain -> SignedExact Certificate-getCertificateChainLeaf (CertificateChain []) = error "empty certificate chain"-getCertificateChainLeaf (CertificateChain (x:_)) = x+getCertificateChainLeaf (CertificateChain []) = error "empty certificate chain"+getCertificateChainLeaf (CertificateChain (x : _)) = x -- | Certificate and Chain rejection reason-data CertificateRejectReason =- CertificateRejectExpired- | CertificateRejectRevoked- | CertificateRejectUnknownCA- | CertificateRejectAbsent- | CertificateRejectOther String- deriving (Show,Eq)+data CertificateRejectReason+ = CertificateRejectExpired+ | CertificateRejectRevoked+ | CertificateRejectUnknownCA+ | CertificateRejectAbsent+ | CertificateRejectOther String+ deriving (Show, Eq) -- | Certificate Usage callback possible returns values.-data CertificateUsage =- CertificateUsageAccept -- ^ usage of certificate accepted- | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected- deriving (Show,Eq)+data CertificateUsage+ = -- | usage of certificate accepted+ CertificateUsageAccept+ | -- | usage of certificate rejected+ CertificateUsageReject CertificateRejectReason+ deriving (Show, Eq) wrapCertificateChecks :: [FailedReason] -> CertificateUsage wrapCertificateChecks [] = CertificateUsageAccept wrapCertificateChecks l- | Expired `elem` l = CertificateUsageReject CertificateRejectExpired- | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired- | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA- | SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA- | EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent- | otherwise = CertificateUsageReject $ CertificateRejectOther (show l)+ | Expired `elem` l = CertificateUsageReject CertificateRejectExpired+ | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired+ | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA+ | SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA+ | EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent+ | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) 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
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
− Tests/Certificate.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Certificate- ( arbitraryX509- , arbitraryX509WithKey- , arbitraryX509WithKeyAndUsage- , arbitraryDN- , arbitraryKeyUsage- , simpleCertificate- , simpleX509- , toPubKeyEC- , toPrivKeyEC- ) where--import Control.Applicative-import Test.Tasty.QuickCheck-import Data.ASN1.OID-import Data.X509-import Data.Hourglass-import Crypto.Number.Serialize (i2ospOf_)-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.Types as ECC-import qualified Data.ByteString as B--import PubKey--arbitraryDN :: Gen DistinguishedName-arbitraryDN = return $ DistinguishedName []--instance Arbitrary Date where- arbitrary = do- y <- choose (1971, 2035)- m <- elements [ January .. December]- d <- choose (1, 30)- return $ normalizeDate $ Date y m d--normalizeDate :: Date -> Date-normalizeDate d = timeConvert (timeConvert d :: Elapsed)--instance Arbitrary TimeOfDay where- arbitrary = do- h <- choose (0, 23)- mi <- choose (0, 59)- se <- choose (0, 59)- nsec <- return 0- return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec--instance Arbitrary DateTime where- arbitrary = DateTime <$> arbitrary <*> arbitrary--maxSerial :: Integer-maxSerial = 16777216--arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate-arbitraryCertificate usageFlags pubKey = do- serial <- choose (0,maxSerial)- subjectdn <- arbitraryDN- validity <- (,) <$> arbitrary <*> arbitrary- let sigalg = getSignatureALG pubKey- return $ Certificate- { certVersion = 3- , certSerial = serial- , certSignatureAlg = sigalg- , certIssuerDN = issuerdn- , certSubjectDN = subjectdn- , certValidity = validity- , certPubKey = pubKey- , certExtensions = Extensions $ Just- [ extensionEncode True $ ExtKeyUsage usageFlags- ]- }- where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")]--simpleCertificate :: PubKey -> Certificate-simpleCertificate pubKey =- Certificate- { certVersion = 3- , certSerial = 0- , certSignatureAlg = getSignatureALG pubKey- , certIssuerDN = simpleDN- , certSubjectDN = simpleDN- , certValidity = (time1, time2)- , certPubKey = pubKey- , certExtensions = Extensions $ Just- [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment]- ]- }- where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0)- time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0)- simpleDN = DistinguishedName []--simpleX509 :: PubKey -> SignedCertificate-simpleX509 pubKey =- let cert = simpleCertificate pubKey- sig = replicate 40 1- sigalg = getSignatureALG pubKey- (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert- in signedExact--arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate-arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage--arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate-arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do- cert <- arbitraryCertificate usageFlags pubKey- sig <- resize 40 $ listOf1 arbitrary- let sigalg = getSignatureALG pubKey- let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert- return signedExact--arbitraryX509 :: Gen SignedCertificate-arbitraryX509 = do- let (pubKey, privKey) = getGlobalRSAPair- arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey)--arbitraryKeyUsage :: Gen [ExtKeyUsageFlag]-arbitraryKeyUsage = sublistOf knownKeyUsage--knownKeyUsage :: [ExtKeyUsageFlag]-knownKeyUsage = [ KeyUsage_digitalSignature- , KeyUsage_keyEncipherment- , KeyUsage_keyAgreement- ]--getSignatureALG :: PubKey -> SignatureALG-getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA-getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA-getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC-getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519-getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448-getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey--toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey-toPubKeyEC curveName key =- let ECC.Point x y = ECDSA.public_q key- pub = SerializedPoint bs- bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y)- bits = ECC.curveSizeBits (ECC.getCurveByName curveName)- bytes = (bits + 7) `div` 8- in PubKeyEC (PubKeyEC_Named curveName pub)--toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey-toPrivKeyEC curveName key =- let priv = ECDSA.private_d key- in PrivKeyEC (PrivKeyEC_Named curveName priv)
− Tests/Ciphers.hs
@@ -1,50 +0,0 @@--- Disable this warning so we can still test deprecated functionality.-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-module Ciphers- ( propertyBulkFunctional- ) where--import Control.Applicative ((<$>), (<*>))--import Test.Tasty.QuickCheck--import qualified Data.ByteString as B-import Network.TLS.Cipher-import Network.TLS.Extra.Cipher--arbitraryKey :: Bulk -> Gen B.ByteString-arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk)--arbitraryIV :: Bulk -> Gen B.ByteString-arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk)--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- deriving (Show,Eq)--instance Arbitrary BulkTest where- arbitrary = do- bulk <- cipherBulk `fmap` elements ciphersuite_all- BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk <*> arbitraryText bulk--propertyBulkFunctional :: BulkTest -> Bool-propertyBulkFunctional (BulkTest bulk key iv t additional) =- let enc = bulkInit bulk BulkEncrypt key- dec = bulkInit bulk BulkDecrypt key- in case (enc, dec) of- (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF- (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF- (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF- _ -> True- where- block e d =- let (etxt, e_iv) = e iv t- (dtxt, d_iv) = d iv etxt- in dtxt == t && d_iv == e_iv- stream e d = (fst . d . fst . e) t == t- aead e d =- let (encrypted, at) = e iv t additional- (decrypted, at2) = d iv encrypted additional- in decrypted == t && at == at2
− Tests/Connection.hs
@@ -1,426 +0,0 @@--- Disable this warning so we can still test deprecated functionality.-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-module Connection- ( newPairContext- , arbitraryCiphers- , arbitraryVersions- , arbitraryHashSignatures- , arbitraryGroups- , arbitraryKeyUsage- , arbitraryPairParams- , arbitraryPairParams13- , arbitraryPairParamsWithVersionsAndCiphers- , arbitraryClientCredential- , arbitraryCredentialsOfEachCurve- , arbitraryRSACredentialWithUsage- , dhParamsGroup- , getConnectVersion- , isVersionEnabled- , isCustomDHParams- , isLeafRSA- , isCredentialDSA- , arbitraryEMSMode- , setEMSMode- , readClientSessionRef- , twoSessionRefs- , twoSessionManagers- , setPairParamsSessionManagers- , setPairParamsSessionResuming- , withDataPipe- , initiateDataPipe- , byeBye- ) where--import Test.Tasty.QuickCheck-import Certificate-import PubKey-import PipeChan-import Network.TLS as TLS-import Network.TLS.Extra-import Data.X509-import Data.Default.Class-import Data.IORef-import Control.Applicative-import Control.Concurrent.Async-import Control.Concurrent.Chan-import Control.Concurrent-import qualified Control.Exception as E-import Control.Monad (unless, when)-import Data.List (intersect, isInfixOf)--import qualified Data.ByteString as B--debug :: Bool-debug = False--knownCiphers :: [Cipher]-knownCiphers = ciphersuite_all ++ ciphersuite_weak- where- ciphersuite_weak = [- cipher_DHE_DSS_RC4_SHA1- , cipher_RC4_128_MD5- , cipher_null_MD5- , cipher_null_SHA1- ]--arbitraryCiphers :: Gen [Cipher]-arbitraryCiphers = listOf1 $ elements knownCiphers--knownVersions :: [Version]-knownVersions = [TLS13,TLS12,TLS11,TLS10]--arbitraryVersions :: Gen [Version]-arbitraryVersions = sublistOf knownVersions---- for performance reason ecdsa_secp521r1_sha512 is not tested-knownHashSignatures :: [HashAndSignatureAlgorithm]-knownHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssRSAeSHA512)- ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA384)- ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA256)- ,(TLS.HashIntrinsic, SignatureEd25519)- ,(TLS.HashIntrinsic, SignatureEd448)- ,(TLS.HashSHA512, SignatureRSA)- ,(TLS.HashSHA384, SignatureRSA)- ,(TLS.HashSHA384, SignatureECDSA)- ,(TLS.HashSHA256, SignatureRSA)- ,(TLS.HashSHA256, SignatureECDSA)- ,(TLS.HashSHA1, SignatureRSA)- ,(TLS.HashSHA1, SignatureDSS)- ]--knownHashSignatures13 :: [HashAndSignatureAlgorithm]-knownHashSignatures13 = filter compat knownHashSignatures- where- compat (h,s) = h /= TLS.HashSHA1 && s /= SignatureDSS && s /= SignatureRSA--arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm]-arbitraryHashSignatures v = sublistOf l- where l = if v < TLS13 then knownHashSignatures else knownHashSignatures13---- for performance reason P521, FFDHE6144, FFDHE8192 are not tested-knownGroups, knownECGroups, knownFFGroups :: [Group]-knownECGroups = [P256,P384,X25519,X448]-knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096]-knownGroups = knownECGroups ++ knownFFGroups--defaultECGroup :: Group-defaultECGroup = P256 -- same as defaultECCurve--otherKnownECGroups :: [Group]-otherKnownECGroups = filter (/= defaultECGroup) knownECGroups--arbitraryGroups :: Gen [Group]-arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups--isCredentialDSA :: (CertificateChain, PrivKey) -> Bool-isCredentialDSA (_, PrivKeyDSA _) = True-isCredentialDSA _ = False--arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)]-arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle--arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)]-arbitraryCredentialsOfEachType' = do- let (pubKey, privKey) = getGlobalRSAPair- curveName = defaultECCurve- (dsaPub, dsaPriv) <- arbitraryDSAPair- (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName- (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair- (ed448Pub, ed448Priv) <- arbitraryEd448Pair- mapM (\(pub, priv) -> do- cert <- arbitraryX509WithKey (pub, priv)- return (CertificateChain [cert], priv)- ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey)- , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv)- , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv)- , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)- , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)- ]--arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)]-arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle--arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)]-arbitraryCredentialsOfEachCurve' = do- ecdsaPairs <-- mapM (\curveName -> do- (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName- return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv)- ) knownECCurves- (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair- (ed448Pub, ed448Priv) <- arbitraryEd448Pair- mapM (\(pub, priv) -> do- cert <- arbitraryX509WithKey (pub, priv)- return (CertificateChain [cert], priv)- ) $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)- , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)- ] ++ ecdsaPairs--dhParamsGroup :: DHParams -> Maybe Group-dhParamsGroup params- | params == ffdhe2048 = Just FFDHE2048- | params == ffdhe3072 = Just FFDHE3072- | otherwise = Nothing--isCustomDHParams :: DHParams -> Bool-isCustomDHParams params = params == dhParams512--leafPublicKey :: CertificateChain -> Maybe PubKey-leafPublicKey (CertificateChain []) = Nothing-leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ getCertificate leaf)--isLeafRSA :: Maybe CertificateChain -> Bool-isLeafRSA chain = case chain >>= leafPublicKey of- Just (PubKeyRSA _) -> True- _ -> False--arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher])-arbitraryCipherPair connectVersion = do- serverCiphers <- arbitraryCiphers `suchThat`- (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs])- clientCiphers <- arbitraryCiphers `suchThat`- (\cs -> or [x `elem` serverCiphers &&- cipherAllowedForVersion connectVersion x | x <- cs])- return (clientCiphers, serverCiphers)--arbitraryPairParams :: Gen (ClientParams, ServerParams)-arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt---- Pair of groups so that at least the default EC group P256 and one FF group--- are in common. This makes DHE and ECDHE ciphers always compatible with--- extension "Supported Elliptic Curves" / "Supported Groups".-arbitraryGroupPair :: Gen ([Group], [Group])-arbitraryGroupPair = do- (serverECGroups, clientECGroups) <- arbitraryGroupPairWith defaultECGroup otherKnownECGroups- (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups- serverGroups <- shuffle (serverECGroups ++ serverFFGroups)- clientGroups <- shuffle (clientECGroups ++ clientFFGroups)- return (clientGroups, serverGroups)- where- arbitraryGroupPairFrom list = elements list >>= \e ->- arbitraryGroupPairWith e (filter (/= e) list)- arbitraryGroupPairWith e es = do- s <- sublistOf es- c <- sublistOf es- return (e : s, e : c)--arbitraryPairParams13 :: Gen (ClientParams, ServerParams)-arbitraryPairParams13 = arbitraryPairParamsAt TLS13--arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams)-arbitraryPairParamsAt connectVersion = do- (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion- -- Select version lists containing connectVersion, as well as some other- -- 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 ]]- allowedVersionsFiltered = filter (<= connectVersion) allowedVersions- -- Server or client is allowed to have versions > connectVersion, but not- -- both simultaneously.- filterSrv <- arbitrary- let (clientAllowedVersions, serverAllowedVersions)- | filterSrv = (allowedVersions, allowedVersionsFiltered)- | otherwise = (allowedVersionsFiltered, allowedVersions)- -- Generate version lists containing less than 127 elements, otherwise the- -- "supported_versions" extension cannot be correctly serialized- clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions- serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions- arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers)- where- listWithOthers :: a -> Int -> [a] -> Gen [a]- listWithOthers fixedElement maxOthers others- | maxOthers < 1 = return [fixedElement]- | otherwise = sized $ \n -> do- num <- choose (0, min n maxOthers)- pos <- choose (0, num)- prefix <- vectorOf pos $ elements others- suffix <- vectorOf (num - pos) $ elements others- return $ prefix ++ (fixedElement : suffix)--getConnectVersion :: (ClientParams, ServerParams) -> Version-getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver)- where- sver = supportedVersions (serverSupported sparams)- cver = supportedVersions (clientSupported cparams)--isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool-isVersionEnabled ver (cparams, sparams) =- (ver `elem` supportedVersions (serverSupported sparams)) &&- (ver `elem` supportedVersions (clientSupported cparams))--arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm])-arbitraryHashSignaturePair = do- serverHashSignatures <- shuffle knownHashSignatures- clientHashSignatures <- shuffle knownHashSignatures- return (clientHashSignatures, serverHashSignatures)--arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version])- -> ([Cipher], [Cipher])- -> Gen (ClientParams, ServerParams)-arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do- secNeg <- arbitrary- dhparams <- elements [dhParams512,ffdhe2048,ffdhe3072]-- creds <- arbitraryCredentialsOfEachType- (clientGroups, serverGroups) <- arbitraryGroupPair- (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair- let serverState = def- { serverSupported = def { supportedCiphers = serverCiphers- , supportedVersions = serverVersions- , supportedSecureRenegotiation = secNeg- , supportedGroups = serverGroups- , supportedHashSignatures = serverHashSignatures- }- , serverDHEParams = Just dhparams- , serverShared = def { sharedCredentials = Credentials creds }- }- let clientState = (defaultParamsClient "" B.empty)- { clientSupported = def { supportedCiphers = clientCiphers- , supportedVersions = clientVersions- , supportedSecureRenegotiation = secNeg- , supportedGroups = clientGroups- , supportedHashSignatures = clientHashSignatures- }- , clientShared = def { sharedValidationCache = ValidationCache- { cacheAdd = \_ _ _ -> return ()- , cacheQuery = \_ _ _ -> return ValidationCachePass- }- }- }- return (clientState, serverState)--arbitraryClientCredential :: Version -> Gen Credential-arbitraryClientCredential SSL3 = do- -- for SSL3 there is no EC but only RSA/DSA- creds <- arbitraryCredentialsOfEachType'- elements (take 2 creds) -- RSA and DSA, but not ECDSA, Ed25519 and Ed448-arbitraryClientCredential v | v < TLS12 = do- -- for TLS10 and TLS11 there is no EdDSA but only RSA/DSA/ECDSA- creds <- arbitraryCredentialsOfEachType'- elements (take 3 creds) -- RSA, DSA and ECDSA, but not EdDSA-arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements--arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey)-arbitraryRSACredentialWithUsage usageFlags = do- let (pubKey, privKey) = getGlobalRSAPair- cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ())- return (CertificateChain [cert], PrivKeyRSA privKey)--arbitraryEMSMode :: Gen (EMSMode, EMSMode)-arbitraryEMSMode = (,) <$> gen <*> gen- where gen = elements [ NoEMS, AllowEMS, RequireEMS ]--setEMSMode :: (EMSMode, EMSMode) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams)-setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam')- where- clientParam' = clientParam { clientSupported = (clientSupported clientParam)- { supportedExtendedMasterSec = cems }- }- serverParam' = serverParam { serverSupported = (serverSupported serverParam)- { supportedExtendedMasterSec = sems }- }--readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient-readClientSessionRef refs = readIORef (fst refs)--twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server))-twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing---- | simple session manager to store one session id and session data for a single thread.--- a Real concurrent session manager would use an MVar and have multiples items.-oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager-oneSessionManager ref = SessionManager- { sessionResume = \myId -> readIORef ref >>= maybeResume False myId- , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId- , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat)- , sessionInvalidate = \_ -> return ()- }- where- maybeResume onlyOnce myId (Just (sid, sdata))- | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata)- maybeResume _ _ _ = return Nothing--twoSessionManagers :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) -> (SessionManager, SessionManager)-twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef)--setPairParamsSessionManagers :: (SessionManager, SessionManager) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams)-setPairParamsSessionManagers (clientManager, serverManager) (clientState, serverState) = (nc,ns)- where nc = clientState { clientShared = updateSessionManager clientManager $ clientShared clientState }- ns = serverState { serverShared = updateSessionManager serverManager $ serverShared serverState }- updateSessionManager manager shared = shared { sharedSessionManager = manager }--setPairParamsSessionResuming :: (SessionID, SessionData) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams)-setPairParamsSessionResuming sessionStuff (clientState, serverState) =- ( clientState { clientWantSessionResume = Just sessionStuff }- , serverState)--newPairContext :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context)-newPairContext pipe (cParams, sParams) = do- let noFlush = return ()- let noClose = return ()-- let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe)- let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe)- cCtx' <- contextNew cBackend cParams- sCtx' <- contextNew sBackend sParams-- contextHookSetLogging cCtx' (logging "client: ")- contextHookSetLogging sCtx' (logging "server: ")-- return (cCtx', sCtx')- where- logging pre =- if debug- then def { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++)- , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) }- else def--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- pipe <- newPipe- _ <- runPipe pipe- startQueue <- newChan- resultQueue <- newChan-- (cCtx, sCtx) <- newPairContext pipe 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--initiateDataPipe :: (ClientParams, ServerParams) -> (Context -> IO a1) -> (Context -> IO a) -> IO (Either E.SomeException a, Either E.SomeException a1)-initiateDataPipe params tlsServer tlsClient = do- -- initial setup- pipe <- newPipe- _ <- runPipe pipe-- (cCtx, sCtx) <- newPairContext pipe params-- async (tlsServer sCtx) >>= \sAsync ->- async (tlsClient cCtx) >>= \cAsync -> do- sRes <- waitCatch sAsync- cRes <- waitCatch cAsync- return (cRes, sRes)---- 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"
− Tests/Marshalling.hs
@@ -1,186 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Marshalling- ( someWords8- , prop_header_marshalling_id- , prop_handshake_marshalling_id- , prop_handshake13_marshalling_id- ) where--import Control.Monad-import Control.Applicative-import Test.Tasty.QuickCheck-import Network.TLS.Internal-import Network.TLS--import qualified Data.ByteString as B-import Data.Word-import Data.X509 (CertificateChain(..))-import Certificate--genByteString :: Int -> Gen B.ByteString-genByteString i = B.pack <$> vector i--instance Arbitrary Version where- arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12, TLS13 ]--instance Arbitrary ProtocolType where- arbitrary = elements- [ ProtocolType_ChangeCipherSpec- , ProtocolType_Alert- , ProtocolType_Handshake- , ProtocolType_AppData ]--instance Arbitrary Header where- arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary ClientRandom where- arbitrary = ClientRandom <$> genByteString 32--instance Arbitrary ServerRandom where- arbitrary = ServerRandom <$> genByteString 32--instance Arbitrary Session where- arbitrary = do- i <- choose (1,2) :: Gen Int- case i of- 2 -> Session . Just <$> genByteString 32- _ -> return $ Session Nothing--instance Arbitrary HashAlgorithm where- arbitrary = elements- [ Network.TLS.HashNone- , Network.TLS.HashMD5- , Network.TLS.HashSHA1- , Network.TLS.HashSHA224- , Network.TLS.HashSHA256- , Network.TLS.HashSHA384- , Network.TLS.HashSHA512- , Network.TLS.HashIntrinsic- ]--instance Arbitrary SignatureAlgorithm where- arbitrary = elements- [ SignatureAnonymous- , SignatureRSA- , SignatureDSS- , SignatureECDSA- , SignatureRSApssRSAeSHA256- , SignatureRSApssRSAeSHA384- , SignatureRSApssRSAeSHA512- , SignatureEd25519- , SignatureEd448- , SignatureRSApsspssSHA256- , SignatureRSApsspssSHA384- , SignatureRSApsspssSHA512- ]--instance Arbitrary DigitallySigned where- arbitrary = DigitallySigned Nothing <$> genByteString 32--arbitraryCiphersIDs :: Gen [Word16]-arbitraryCiphersIDs = choose (0,200) >>= vector--arbitraryCompressionIDs :: Gen [Word8]-arbitraryCompressionIDs = choose (0,200) >>= vector--someWords8 :: Int -> Gen [Word8]-someWords8 = vector--instance Arbitrary ExtensionRaw where- arbitrary =- let arbitraryContent = choose (0,40) >>= genByteString- in ExtensionRaw <$> arbitrary <*> arbitraryContent--arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw]-arbitraryHelloExtensions ver- | ver >= SSL3 = arbitrary- | otherwise = return [] -- no hello extension with SSLv2--instance Arbitrary CertificateType where- arbitrary = elements- [ CertificateType_RSA_Sign, CertificateType_DSS_Sign- , CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH- , CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH- , CertificateType_fortezza_dms ]--instance Arbitrary Handshake where- arbitrary = oneof- [ arbitrary >>= \ver -> ClientHello ver- <$> arbitrary- <*> arbitrary- <*> arbitraryCiphersIDs- <*> arbitraryCompressionIDs- <*> arbitraryHelloExtensions ver- <*> return Nothing- , arbitrary >>= \ver -> ServerHello ver- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver- , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509)- , pure HelloRequest- , pure ServerHelloDone- , ClientKeyXchg . CKX_RSA <$> genByteString 48- --, liftM ServerKeyXchg- , liftM3 CertRequest arbitrary (return Nothing) (listOf arbitraryDN)- , CertVerify <$> arbitrary- , Finished <$> genByteString 12- ]--arbitraryCertReqContext :: Gen B.ByteString-arbitraryCertReqContext = oneof [ return B.empty, genByteString 32 ]--instance Arbitrary Handshake13 where- arbitrary = oneof- [ arbitrary >>= \ver -> ClientHello13 ver- <$> arbitrary- <*> arbitrary- <*> arbitraryCiphersIDs- <*> arbitraryHelloExtensions ver- , arbitrary >>= \ver -> ServerHello13- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver- , NewSessionTicket13- <$> arbitrary- <*> arbitrary- <*> genByteString 32 -- nonce- <*> genByteString 32 -- session ID- <*> arbitrary- , pure EndOfEarlyData13- , EncryptedExtensions13 <$> arbitrary- , CertRequest13- <$> arbitraryCertReqContext- <*> arbitrary- , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13- <$> arbitraryCertReqContext- <*> return (CertificateChain certs)- <*> replicateM (length certs) arbitrary- , CertVerify13 <$> arbitrary <*> genByteString 32- , Finished13 <$> genByteString 12- , KeyUpdate13 <$> elements [ UpdateNotRequested, UpdateRequested ]- ]--{- quickcheck property -}--prop_header_marshalling_id :: Header -> Bool-prop_header_marshalling_id x = decodeHeader (encodeHeader x) == Right x--prop_handshake_marshalling_id :: Handshake -> Bool-prop_handshake_marshalling_id x = decodeHs (encodeHandshake x) == Right x- where decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b- cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA }--prop_handshake13_marshalling_id :: Handshake13 -> Bool-prop_handshake13_marshalling_id x = decodeHs (encodeHandshake13 x) == Right x- where decodeHs b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b--verifyResult :: (t -> b -> r) -> GetResult (t, b) -> r-verifyResult fn result =- case result of- GotPartial _ -> error "got partial"- GotError e -> error ("got error: " ++ show e)- GotSuccessRemaining _ _ -> error "got remaining byte left"- GotSuccess (ty, content) -> fn ty content
− Tests/PipeChan.hs
@@ -1,70 +0,0 @@--- create a similar concept than a unix pipe.-module PipeChan- ( PipeChan(..)- , newPipe- , runPipe- , readPipeA- , readPipeB- , writePipeA- , writePipeB- ) where--import Control.Applicative-import Control.Concurrent.Chan-import Control.Concurrent-import Control.Monad (forever)-import Data.ByteString (ByteString)-import Data.IORef-import qualified Data.ByteString as B---- | represent a unidirectional pipe with a buffered read channel and a write channel-data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString)--newUniPipeChan :: IO UniPipeChan-newUniPipeChan = UniPipeChan <$> newChan <*> newChan--runUniPipe :: UniPipeChan -> IO ThreadId-runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w--getReadUniPipe :: UniPipeChan -> Chan ByteString-getReadUniPipe (UniPipeChan r _) = r--getWriteUniPipe :: UniPipeChan -> Chan ByteString-getWriteUniPipe (UniPipeChan _ w) = w---- | Represent a bidirectional pipe with 2 nodes A and B-data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan--newPipe :: IO PipeChan-newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan--runPipe :: PipeChan -> IO ThreadId-runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC--readPipeA :: PipeChan -> Int -> IO ByteString-readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz--writePipeA :: PipeChan -> ByteString -> IO ()-writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c--readPipeB :: PipeChan -> Int -> IO ByteString-readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz--writePipeB :: PipeChan -> ByteString -> IO ()-writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s---- helper to read buffered data.-readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString-readBuffered buf chan sz = do- left <- readIORef buf- if B.length left >= sz- then do- let (ret, nleft) = B.splitAt sz left- writeIORef buf nleft- return ret- else do- let newSize = (sz - B.length left)- newData <- readChan chan- writeIORef buf newData- remain <- readBuffered buf chan newSize- return (left `B.append` remain)
− Tests/PubKey.hs
@@ -1,133 +0,0 @@-module PubKey- ( arbitraryRSAPair- , arbitraryDSAPair- , arbitraryECDSAPair- , arbitraryEd25519Pair- , arbitraryEd448Pair- , globalRSAPair- , getGlobalRSAPair- , knownECCurves- , defaultECCurve- , dhParams512- , dhParams768- , dhParams1024- , dsaParams- , rsaParams- ) where--import Test.Tasty.QuickCheck--import qualified Data.ByteString as B-import qualified Crypto.PubKey.DH as DH-import Crypto.Error-import Crypto.Random-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.DSA as DSA-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.Prim as ECC-import qualified Crypto.PubKey.ECC.Types as ECC-import qualified Crypto.PubKey.Ed25519 as Ed25519-import qualified Crypto.PubKey.Ed448 as Ed448--import Control.Concurrent.MVar-import System.IO.Unsafe--arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey)-arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary- where- rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey)- rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG--arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey)-arbitraryRSAPairWithRNG = RSA.generate 256 0x10001--{-# NOINLINE globalRSAPair #-}-globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey)-globalRSAPair = unsafePerformIO $ do- drg <- drgNew- newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG)--{-# NOINLINE getGlobalRSAPair #-}-getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey)-getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair)--rsaParams :: (RSA.PublicKey, RSA.PrivateKey)-rsaParams = (pub, priv)- where priv = RSA.PrivateKey { RSA.private_pub = pub- , RSA.private_d = d- , RSA.private_p = 0- , RSA.private_q = 0- , RSA.private_dP = 0- , RSA.private_dQ = 0- , RSA.private_qinv = 0- }- pub = RSA.PublicKey { RSA.public_size = (1024 `div` 8), RSA.public_n = n, RSA.public_e = e }- n = 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7- e = 0x10001- d = 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481--dhParams512 :: DH.Params-dhParams512 = DH.Params- { DH.params_p = 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb- , DH.params_g = 0x2- , DH.params_bits = 512- }---- from RFC 2409--dhParams768 :: DH.Params-dhParams768 = DH.Params- { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a63a3620ffffffffffffffff- , DH.params_g = 0x2- , DH.params_bits = 768- }--dhParams1024 :: DH.Params-dhParams1024 = DH.Params- { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece65381ffffffffffffffff- , DH.params_g = 0x2- , DH.params_bits = 1024- }--dsaParams :: DSA.Params-dsaParams = DSA.Params- { DSA.params_p = 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb- , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b- , DSA.params_g = 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff- }--arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey)-arbitraryDSAPair = do- priv <- choose (1, DSA.params_q dsaParams)- let pub = DSA.calculatePublic dsaParams priv- return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv)---- for performance reason P521 is not tested-knownECCurves :: [ECC.CurveName]-knownECCurves = [ ECC.SEC_p256r1- , ECC.SEC_p384r1- ]--defaultECCurve :: ECC.CurveName-defaultECCurve = ECC.SEC_p256r1--arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey)-arbitraryECDSAPair curveName = do- d <- choose (1, n - 1)- let p = ECC.pointBaseMul curve d- return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d)- where- curve = ECC.getCurveByName curveName- n = ECC.ecc_n . ECC.common_curve $ curve--arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey)-arbitraryEd25519Pair = do- bytes <- vectorOf 32 arbitrary- let CryptoPassed priv = Ed25519.secretKey (B.pack bytes)- return (Ed25519.toPublic priv, priv)--arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey)-arbitraryEd448Pair = do- bytes <- vectorOf 57 arbitrary- let CryptoPassed priv = Ed448.secretKey (B.pack bytes)- return (Ed448.toPublic priv, priv)
− Tests/Tests.hs
@@ -1,1054 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Test.Tasty-import Test.Tasty.QuickCheck-import Test.QuickCheck.Monadic--import PipeChan-import Connection-import Marshalling-import Ciphers-import PubKey--import Data.Foldable (traverse_)-import Data.Maybe-import Data.Default.Class-import Data.List (intersect)--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Lazy as L-import Network.TLS-import Network.TLS.Extra-import Network.TLS.Internal-import Control.Applicative-import Control.Concurrent-import Control.Concurrent.Async-import Control.Monad--import Data.IORef-import Data.X509 (ExtKeyUsageFlag(..))--import System.Timeout--prop_pipe_work :: PropertyM IO ()-prop_pipe_work = do- pipe <- run newPipe- _ <- run (runPipe pipe)-- let bSize = 16- n <- pick (choose (1, 32))-- let d1 = B.replicate (bSize * n) 40- let d2 = B.replicate (bSize * n) 45-- d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1))- d1 `assertEq` d1'-- d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2))- d2 `assertEq` d2'-- return ()--chunkLengths :: Int -> [Int]-chunkLengths len- | len > 16384 = 16384 : chunkLengths (len - 16384)- | len > 0 = [len]- | otherwise = []--runTLSPipeN :: Int -> (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()-runTLSPipeN n params tlsServer tlsClient = do- -- generate some data to send- ds <- replicateM n $ do- d <- B.pack <$> pick (someWords8 256)- return d- -- send it- m_dsres <- run $ do- withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do- forM_ ds $ \d -> do- writeStart d- -- receive it- timeout 60000000 readResult -- 60 sec- case m_dsres of- Nothing -> error "timed out"- Just dsres -> ds `assertEq` dsres--runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()-runTLSPipe = runTLSPipeN 1--runTLSPipePredicate :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO ()-runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient- where tlsServer ctx queue = do- handshake ctx- checkCtxFinished ctx- checkInfoPredicate ctx- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient queue ctx = do- handshake ctx- checkCtxFinished ctx- checkInfoPredicate ctx- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- checkInfoPredicate ctx = do- minfo <- contextGetInformation ctx- unless (p minfo) $- fail ("unexpected information: " ++ show minfo)--runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO ()-runTLSPipeSimple params = runTLSPipePredicate params (const True)--runTLSPipeSimple13 :: (ClientParams, ServerParams) -> HandshakeMode13 -> Maybe C8.ByteString -> PropertyM IO ()-runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient- where tlsServer ctx queue = do- handshake ctx- case mEarlyData of- Nothing -> return ()- Just ed -> do- let ls = chunkLengths (B.length ed)- chunks <- replicateM (length ls) $ recvData ctx- (ls, ed) `assertEq` (map B.length chunks, B.concat chunks)- d <- recvData ctx- checkCtxFinished ctx- writeChan queue [d]- minfo <- contextGetInformation ctx- Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode)- bye ctx- tlsClient queue ctx = do- handshake ctx- checkCtxFinished ctx- d <- readChan queue- sendData ctx (L.fromChunks [d])- minfo <- contextGetInformation ctx- Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode)- byeBye ctx--runTLSPipeCapture13 :: (ClientParams, ServerParams) -> PropertyM IO ([Handshake13], [Handshake13])-runTLSPipeCapture13 params = do- sRef <- run $ newIORef []- cRef <- run $ newIORef []- runTLSPipe params (tlsServer sRef) (tlsClient cRef)- sReceived <- run $ readIORef sRef- cReceived <- run $ readIORef cRef- return (reverse sReceived, reverse cReceived)- where tlsServer ref ctx queue = do- installHook ctx ref- handshake ctx- checkCtxFinished ctx- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient ref queue ctx = do- installHook ctx ref- handshake ctx- checkCtxFinished ctx- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- installHook ctx ref =- let recv hss = modifyIORef ref (hss :) >> return hss- in contextHookSetHandshake13Recv ctx recv--runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO ()-runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient- where tlsServer ctx queue = do- handshake ctx- checkCtxFinished ctx- d0 <- recvData ctx- req <- generate $ elements [OneWay, TwoWay]- _ <- updateKey ctx req- d1 <- recvData ctx- d2 <- recvData ctx- writeChan queue [d0,d1,d2]- bye ctx- tlsClient queue ctx = do- handshake ctx- checkCtxFinished ctx- d0 <- readChan queue- sendData ctx (L.fromChunks [d0])- d1 <- readChan queue- sendData ctx (L.fromChunks [d1])- req <- generate $ elements [OneWay, TwoWay]- _ <- updateKey ctx req- d2 <- readChan queue- sendData ctx (L.fromChunks [d2])- byeBye ctx--runTLSInitFailureGen :: (ClientParams, ServerParams) -> (Context -> IO s) -> (Context -> IO c) -> PropertyM IO ()-runTLSInitFailureGen params hsServer hsClient = do- (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient)- assertIsLeft cRes- assertIsLeft sRes- where tlsServer ctx = do- _ <- hsServer ctx- checkCtxFinished ctx- minfo <- contextGetInformation ctx- byeBye ctx- return $ "server success: " ++ show minfo- tlsClient ctx = do- _ <- hsClient ctx- checkCtxFinished ctx- minfo <- contextGetInformation ctx- byeBye ctx- return $ "client success: " ++ show minfo--runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO ()-runTLSInitFailure params = runTLSInitFailureGen params handshake handshake--prop_handshake_initiate :: PropertyM IO ()-prop_handshake_initiate = do- params <- pick arbitraryPairParams- runTLSPipeSimple params--prop_handshake13_initiate :: PropertyM IO ()-prop_handshake13_initiate = do- params <- pick arbitraryPairParams13- let cgrps = supportedGroups $ clientSupported $ fst params- sgrps = supportedGroups $ serverSupported $ snd params- hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest- runTLSPipeSimple13 params hs Nothing--prop_handshake_keyupdate :: PropertyM IO ()-prop_handshake_keyupdate = do- params <- pick arbitraryPairParams- runTLSPipeSimpleKeyUpdate params--prop_handshake13_downgrade :: PropertyM IO ()-prop_handshake13_downgrade = do- (cparam,sparam) <- pick arbitraryPairParams- versionForced <- pick $ 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 runTLSInitFailure params- else runTLSPipeSimple params--prop_handshake13_full :: PropertyM IO ()-prop_handshake13_full = do- (cli, srv) <- pick arbitraryPairParams13- 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 }- )- runTLSPipeSimple13 params FullHandshake Nothing--prop_handshake13_hrr :: PropertyM IO ()-prop_handshake13_hrr = do- (cli, srv) <- pick arbitraryPairParams13- 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 }- )- runTLSPipeSimple13 params HelloRetryRequest Nothing--prop_handshake13_psk :: PropertyM IO ()-prop_handshake13_psk = do- (cli, srv) <- pick arbitraryPairParams13- 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 <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params = setPairParamsSessionManagers sessionManagers params0-- runTLSPipeSimple13 params HelloRetryRequest Nothing-- -- and resume- sessionParams <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- let params2 = setPairParamsSessionResuming (fromJust sessionParams) params-- runTLSPipeSimple13 params2 PreSharedKey Nothing--prop_handshake13_psk_fallback :: PropertyM IO ()-prop_handshake13_psk_fallback = do- (cli, srv) <- pick arbitraryPairParams13- 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 <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params = setPairParamsSessionManagers sessionManagers params0-- runTLSPipeSimple13 params HelloRetryRequest Nothing-- -- 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 <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params- srv2' = srv2 { serverSupported = svrSupported' }- svrSupported' = def- { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256]- , supportedGroups = [P256]- }-- runTLSPipeSimple13 (cli2, srv2') HelloRetryRequest Nothing--prop_handshake13_rtt0 :: PropertyM IO ()-prop_handshake13_rtt0 = do- (cli, srv) <- pick arbitraryPairParams13- 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 (\protos -> return $ head protos)- }- params0 = (cli { clientSupported = cliSupported- , clientHooks = cliHooks- }- ,srv { serverSupported = svrSupported- , serverHooks = svrHooks- , serverEarlyDataSize = 2048 }- )-- sessionRefs <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params = setPairParamsSessionManagers sessionManagers params0-- runTLSPipeSimple13 params HelloRetryRequest Nothing-- -- and resume- sessionParams <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- earlyData <- B.pack <$> pick (someWords8 256)- let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params- params2 = (pc { clientEarlyData = Just earlyData } , ps)-- runTLSPipeSimple13 params2 RTT0 (Just earlyData)--prop_handshake13_rtt0_fallback :: PropertyM IO ()-prop_handshake13_rtt0_fallback = do- ticketSize <- pick $ choose (0, 512)- (cli, srv) <- pick arbitraryPairParams13- group0 <- pick $ elements [P256,X25519]- let cliSupported = def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [P256,X25519]- }- svrSupported = def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [group0]- }- params0 = (cli { clientSupported = cliSupported }- ,srv { serverSupported = svrSupported- , serverEarlyDataSize = ticketSize }- )-- sessionRefs <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- let params = setPairParamsSessionManagers sessionManagers params0-- let mode = if group0 == P256 then FullHandshake else HelloRetryRequest- runTLSPipeSimple13 params mode Nothing-- -- and resume- sessionParams <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- earlyData <- B.pack <$> pick (someWords8 256)- group2 <- pick $ elements [P256,X25519]- let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params- svrSupported2 = def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [group2]- }- params2 = (pc { clientEarlyData = Just earlyData }- ,ps { serverEarlyDataSize = 0- , serverSupported = svrSupported2- }- )-- let mode2 = if ticketSize < 256 then PreSharedKey else RTT0- runTLSPipeSimple13 params2 mode2 Nothing--prop_handshake13_rtt0_length :: PropertyM IO ()-prop_handshake13_rtt0_length = do- serverMax <- pick $ choose (0, 33792)- (cli, srv) <- pick arbitraryPairParams13- let cliSupported = def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- svrSupported = def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]- , supportedGroups = [X25519]- }- params0 = (cli { clientSupported = cliSupported }- ,srv { serverSupported = svrSupported- , serverEarlyDataSize = serverMax }- )-- sessionRefs <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs- let params = setPairParamsSessionManagers sessionManagers params0- runTLSPipeSimple13 params FullHandshake Nothing-- -- and resume- sessionParams <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- clientLen <- pick $ choose (0, 33792)- earlyData <- B.pack <$> pick (someWords8 clientLen)- let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params- params2 = (pc { clientEarlyData = Just earlyData } , ps)- (mode, mEarlyData)- | clientLen > serverMax = (PreSharedKey, Nothing)- | otherwise = (RTT0, Just earlyData)- runTLSPipeSimple13 params2 mode mEarlyData--prop_handshake13_ee_groups :: PropertyM IO ()-prop_handshake13_ee_groups = do- (cli, srv) <- pick arbitraryPairParams13- let cliSupported = (clientSupported cli) { supportedGroups = [P256,X25519] }- svrSupported = (serverSupported srv) { supportedGroups = [X25519,P256] }- params = (cli { clientSupported = cliSupported }- ,srv { serverSupported = svrSupported }- )- (_, serverMessages) <- runTLSPipeCapture13 params- let isNegotiatedGroups (ExtensionRaw eid _) = eid == 0xa- eeMessagesHaveExt = [ any isNegotiatedGroups exts |- EncryptedExtensions13 exts <- serverMessages ]- [True] `assertEq` eeMessagesHaveExt -- one EE message with extension--prop_handshake_ciphersuites :: PropertyM IO ()-prop_handshake_ciphersuites = do- tls13 <- pick arbitrary- let version = if tls13 then TLS13 else TLS12- clientCiphers <- pick arbitraryCiphers- serverCiphers <- pick arbitraryCiphers- (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- ([version], [version])- (clientCiphers, serverCiphers)- let adequate = cipherAllowedForVersion version- shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers)- if shouldSucceed- then runTLSPipeSimple (clientParam,serverParam)- else runTLSInitFailure (clientParam,serverParam)--prop_handshake_hashsignatures :: PropertyM IO ()-prop_handshake_hashsignatures = do- tls13 <- pick arbitrary- let version = if tls13 then TLS13 else TLS12- ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_ECDSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_AES128CBC_SHA- , cipher_ECDHE_ECDSA_AES128CBC_SHA- , cipher_DHE_RSA_AES128_SHA1- , cipher_DHE_DSS_AES128_SHA1- , cipher_TLS13_AES128GCM_SHA256- ]- (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- ([version], [version])- (ciphers, ciphers)- clientHashSigs <- pick $ arbitraryHashSignatures version- serverHashSigs <- pick $ arbitraryHashSignatures version- 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 runTLSInitFailure (clientParam',serverParam')- else runTLSPipeSimple (clientParam',serverParam')- where- incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256- incompatibleWithDefaultCurve _ = False---- 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_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA--- certificate.-prop_handshake_cert_fallback :: PropertyM IO ()-prop_handshake_cert_fallback = do- let clientVersions = [TLS12]- serverVersions = [TLS12]- commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ]- otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_AES128CBC_SHA- , cipher_DHE_DSS_AES128_SHA1- ]- hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ]- chainRef <- run $ newIORef Nothing- clientCiphers <- pick $ sublistOf otherCiphers- serverCiphers <- pick $ sublistOf otherCiphers- (clientParam,serverParam) <- pick $ 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 [] }- }- dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers- || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers- runTLSPipeSimple (clientParam',serverParam)- serverChain <- run $ readIORef chainRef- dssDisallowed `assertEq` isLeafRSA serverChain---- 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.-prop_handshake_cert_fallback_hs :: PropertyM IO ()-prop_handshake_cert_fallback_hs = do- tls13 <- pick 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)- ]- otherHS = [ (HashIntrinsic, SignatureEd25519) ]- chainRef <- run $ newIORef Nothing- clientHS <- pick $ sublistOf otherHS- serverHS <- pick $ sublistOf otherHS- (clientParam,serverParam) <- pick $ 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- runTLSPipeSimple (clientParam',serverParam')- serverChain <- run $ readIORef chainRef- eddsaDisallowed `assertEq` isLeafRSA serverChain--prop_handshake_groups :: PropertyM IO ()-prop_handshake_groups = do- tls13 <- pick arbitrary- let versions = if tls13 then [TLS13] else [TLS12]- ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384- , cipher_ECDHE_RSA_AES128CBC_SHA- , cipher_DHE_RSA_AES256GCM_SHA384- , cipher_DHE_RSA_AES128_SHA1- , cipher_TLS13_AES128GCM_SHA256- ]- (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- (versions, versions)- (ciphers, ciphers)- clientGroups <- pick arbitraryGroups- serverGroups <- pick arbitraryGroups- denyCustom <- pick 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 }- }- isCustom = maybe True isCustomDHParams (serverDHEParams serverParam')- mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup- isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup- commonGroups = clientGroups `intersect` serverGroups- shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom)- p minfo = isNothing (minfo >>= infoNegotiatedGroup) == (null commonGroups && isCustom)- if shouldFail- then runTLSInitFailure (clientParam',serverParam')- else runTLSPipePredicate (clientParam',serverParam') p---prop_handshake_dh :: PropertyM IO ()-prop_handshake_dh = do- let clientVersions = [TLS12]- serverVersions = [TLS12]- ciphers = [ cipher_DHE_RSA_AES128_SHA1 ]- (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- (clientVersions, serverVersions)- (ciphers, ciphers)- let clientParam' = clientParam { clientSupported = (clientSupported clientParam)- { supportedGroups = [] }- }- let check (dh,shouldFail) = do- let serverParam' = serverParam { serverDHEParams = Just dh }- if shouldFail- then runTLSInitFailure (clientParam',serverParam')- else runTLSPipeSimple (clientParam',serverParam')- mapM_ check [(dhParams512,True)- ,(dhParams768,True)- ,(dhParams1024,False)]--prop_handshake_srv_key_usage :: PropertyM IO ()-prop_handshake_srv_key_usage = do- tls13 <- pick arbitrary- let versions = if tls13 then [TLS13] else [TLS12,TLS11,TLS10,SSL3]- ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA- , cipher_TLS13_AES128GCM_SHA256- , cipher_DHE_RSA_AES128_SHA1- , cipher_AES256_SHA256- ]- (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- (versions, versions)- (ciphers, ciphers)- usageFlags <- pick arbitraryKeyUsage- cred <- pick $ arbitraryRSACredentialWithUsage usageFlags- let serverParam' = serverParam- { serverShared = (serverShared serverParam)- { sharedCredentials = Credentials [cred]- }- }- hasDS = KeyUsage_digitalSignature `elem` usageFlags- hasKE = KeyUsage_keyEncipherment `elem` usageFlags- shouldSucceed = hasDS || (hasKE && not tls13)- if shouldSucceed- then runTLSPipeSimple (clientParam,serverParam')- else runTLSInitFailure (clientParam,serverParam')--prop_handshake_ec :: PropertyM IO ()-prop_handshake_ec = do- let versions = [TLS10, TLS11, TLS12, TLS13]- ciphers = [ cipher_ECDHE_ECDSA_AES256GCM_SHA384- , cipher_ECDHE_ECDSA_AES128CBC_SHA- , cipher_TLS13_AES128GCM_SHA256- ]- sigGroups = [P256]- ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure- hashSignatures = [ (HashSHA256, SignatureECDSA)- ]- clientVersion <- pick $ elements versions- (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- ([clientVersion], versions)- (ciphers, ciphers)- clientGroups <- pick $ sublistOf sigGroups- clientHashSignatures <- pick $ sublistOf hashSignatures- serverHashSignatures <- pick $ sublistOf hashSignatures- credentials <- pick arbitraryCredentialsOfEachCurve- let clientParam' = clientParam { clientSupported = (clientSupported clientParam)- { supportedGroups = clientGroups ++ ecdhGroups- , supportedHashSignatures = clientHashSignatures- }- }- serverParam' = serverParam { serverSupported = (serverSupported serverParam)- { supportedGroups = sigGroups ++ ecdhGroups- , supportedHashSignatures = serverHashSignatures- }- , serverShared = (serverShared serverParam)- { sharedCredentials = Credentials credentials }- }- sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures)- ecdsaDenied = (clientVersion < TLS13 && null clientGroups) ||- (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs)- if ecdsaDenied- then runTLSInitFailure (clientParam',serverParam')- else runTLSPipeSimple (clientParam',serverParam')--prop_handshake_client_auth :: PropertyM IO ()-prop_handshake_client_auth = do- (clientParam,serverParam) <- pick arbitraryPairParams- let clientVersions = supportedVersions $ clientSupported clientParam- serverVersions = supportedVersions $ serverSupported serverParam- version = maximum (clientVersions `intersect` serverVersions)- cred <- pick (arbitraryClientCredential version)- let clientParam' = clientParam { clientHooks = (clientHooks clientParam)- { onCertificateRequest = \_ -> return $ Just cred }- }- serverParam' = serverParam { serverWantClientCert = True- , serverHooks = (serverHooks serverParam)- { onClientCertificate = validateChain cred }- }- let shouldFail = version == TLS13 && isCredentialDSA cred- if shouldFail- then runTLSInitFailure (clientParam',serverParam')- else runTLSPipeSimple (clientParam',serverParam')- where validateChain cred chain- | chain == fst cred = return CertificateUsageAccept- | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)--prop_post_handshake_auth :: PropertyM IO ()-prop_post_handshake_auth = do- (clientParam,serverParam) <- pick arbitraryPairParams13- cred <- pick (arbitraryClientCredential TLS13)- let clientParam' = clientParam { clientHooks = (clientHooks clientParam)- { onCertificateRequest = \_ -> return $ Just cred }- }- serverParam' = serverParam { serverHooks = (serverHooks serverParam)- { onClientCertificate = validateChain cred }- }- if isCredentialDSA cred- then runTLSInitFailureGen (clientParam',serverParam') hsServer hsClient- else runTLSPipe (clientParam',serverParam') tlsServer tlsClient- where validateChain cred chain- | chain == fst cred = return CertificateUsageAccept- | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)- tlsServer ctx queue = do- hsServer ctx- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient queue ctx = do- hsClient ctx- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- hsServer ctx = do- handshake ctx- checkCtxFinished 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"- hsClient ctx = do- handshake ctx- checkCtxFinished ctx- sendData ctx "request 1"- recvDataAssert ctx "response 1"- sendData ctx "request 2"- recvDataAssert ctx "response 2"--prop_handshake_clt_key_usage :: PropertyM IO ()-prop_handshake_clt_key_usage = do- (clientParam,serverParam) <- pick arbitraryPairParams- usageFlags <- pick arbitraryKeyUsage- cred <- pick $ 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 runTLSPipeSimple (clientParam',serverParam')- else runTLSInitFailure (clientParam',serverParam')--prop_handshake_ems :: PropertyM IO ()-prop_handshake_ems = do- (cems, sems) <- pick arbitraryEMSMode- params <- pick arbitraryPairParams- 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 = infoExtendedMasterSec info == (emsVersion && use)- if emsVersion && require && not use- then runTLSInitFailure params'- else runTLSPipePredicate params' (maybe False p)--prop_handshake_session_resumption_ems :: PropertyM IO ()-prop_handshake_session_resumption_ems = do- sessionRefs <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- plainParams <- pick arbitraryPairParams- ems <- pick (arbitraryEMSMode `suchThat` compatible)- let params = setEMSMode ems $- setPairParamsSessionManagers sessionManagers plainParams-- runTLSPipeSimple params-- -- and resume- sessionParams <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- ems2 <- pick (arbitraryEMSMode `suchThat` compatible)- 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 runTLSInitFailure params2- else do- runTLSPipeSimple params2- sessionParams2 <- run $ readClientSessionRef sessionRefs- let sameSession = sessionParams == sessionParams2- sameUse = use ems == use ems2- when emsVersion $ assert (sameSession == sameUse)- where- compatible (NoEMS, RequireEMS) = False- compatible (RequireEMS, NoEMS) = False- compatible _ = True-- use (NoEMS, _) = False- use (_, NoEMS) = False- use _ = True--prop_handshake_alpn :: PropertyM IO ()-prop_handshake_alpn = do- (clientParam,serverParam) <- pick arbitraryPairParams- let clientParam' = clientParam { clientHooks = (clientHooks clientParam)- { onSuggestALPN = return $ Just ["h2", "http/1.1"] }- }- serverParam' = serverParam { serverHooks = (serverHooks serverParam)- { onALPNClientSuggest = Just alpn }- }- params' = (clientParam',serverParam')- runTLSPipe params' tlsServer tlsClient- where tlsServer ctx queue = do- handshake ctx- checkCtxFinished ctx- proto <- getNegotiatedProtocol ctx- Just "h2" `assertEq` proto- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient queue ctx = do- handshake ctx- checkCtxFinished ctx- proto <- getNegotiatedProtocol ctx- Just "h2" `assertEq` proto- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- alpn xs- | "h2" `elem` xs = return "h2"- | otherwise = return "http/1.1"--prop_handshake_sni :: PropertyM IO ()-prop_handshake_sni = do- ref <- run $ newIORef Nothing- (clientParam,serverParam) <- pick arbitraryPairParams- let clientParam' = clientParam { clientServerIdentification = (serverName, "")- }- serverParam' = serverParam { serverHooks = (serverHooks serverParam)- { onServerNameIndication = onSNI ref }- }- params' = (clientParam',serverParam')- runTLSPipe params' tlsServer tlsClient- receivedName <- run $ readIORef ref- Just (Just serverName) `assertEq` receivedName- where tlsServer ctx queue = do- handshake ctx- checkCtxFinished ctx- sni <- getClientSNI ctx- Just serverName `assertEq` sni- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient queue ctx = do- handshake ctx- checkCtxFinished ctx- sni <- getClientSNI ctx- Just serverName `assertEq` sni- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- onSNI ref name = assertEmptyRef ref >> writeIORef ref (Just name) >>- return (Credentials [])- serverName = "haskell.org"--prop_handshake_renegotiation :: PropertyM IO ()-prop_handshake_renegotiation = do- renegDisabled <- pick arbitrary- (cparams, sparams) <- pick arbitraryPairParams- let sparams' = sparams {- serverSupported = (serverSupported sparams) {- supportedClientInitiatedRenegotiation = not renegDisabled- }- }- if renegDisabled || isVersionEnabled TLS13 (cparams, sparams')- then runTLSInitFailureGen (cparams, sparams') hsServer hsClient- else runTLSPipe (cparams, sparams') tlsServer tlsClient- where tlsServer ctx queue = do- hsServer ctx- checkCtxFinished ctx- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient queue ctx = do- hsClient ctx- checkCtxFinished ctx- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- hsServer = handshake- hsClient ctx = handshake ctx >> handshake ctx--prop_handshake_session_resumption :: PropertyM IO ()-prop_handshake_session_resumption = do- sessionRefs <- run twoSessionRefs- let sessionManagers = twoSessionManagers sessionRefs-- plainParams <- pick arbitraryPairParams- let params = setPairParamsSessionManagers sessionManagers plainParams-- runTLSPipeSimple params-- -- and resume- sessionParams <- run $ readClientSessionRef sessionRefs- assert (isJust sessionParams)- let params2 = setPairParamsSessionResuming (fromJust sessionParams) params-- runTLSPipeSimple params2--prop_thread_safety :: PropertyM IO ()-prop_thread_safety = do- params <- pick arbitraryPairParams- runTLSPipe params tlsServer tlsClient- where tlsServer ctx queue = do- handshake ctx- checkCtxFinished ctx- runReaderWriters ctx "client-value" "server-value"- d <- recvData ctx- writeChan queue [d]- bye ctx- tlsClient queue ctx = do- handshake ctx- checkCtxFinished ctx- runReaderWriters ctx "server-value" "client-value"- d <- readChan queue- sendData ctx (L.fromChunks [d])- byeBye ctx- runReaderWriters ctx r w =- -- run concurrently 10 readers and 10 writers on the same context- let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w]- in runConcurrently $ traverse_ Concurrently workers--assertEq :: (Show a, Monad m, Eq a) => a -> a -> m ()-assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected)--assertIsLeft :: (Show b, Monad m) => Either a b -> m ()-assertIsLeft (Left _) = return ()-assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure")--assertEmptyRef :: Show a => IORef (Maybe a) -> IO ()-assertEmptyRef ref = readIORef ref >>= maybe (return ()) (\a ->- error ("got " ++ show a ++ " but was expecting empty reference"))--recvDataAssert :: Context -> C8.ByteString -> IO ()-recvDataAssert ctx expected = do- got <- recvData ctx- assertEq expected got--checkCtxFinished :: Context -> IO ()-checkCtxFinished ctx = do- ctxFinished <- getFinished ctx- unless (isJust ctxFinished) $- fail "unexpected ctxFinished"- ctxPeerFinished <- getPeerFinished ctx- unless (isJust ctxPeerFinished) $- fail "unexpected ctxPeerFinished"--main :: IO ()-main = defaultMain $ testGroup "tls"- [ tests_marshalling- , tests_ciphers- , tests_handshake- , tests_thread_safety- ]- where -- lowlevel tests to check the packet marshalling.- tests_marshalling = testGroup "Marshalling"- [ testProperty "Header" prop_header_marshalling_id- , testProperty "Handshake" prop_handshake_marshalling_id- , testProperty "Handshake13" prop_handshake13_marshalling_id- ]- tests_ciphers = testGroup "Ciphers"- [ testProperty "Bulk" propertyBulkFunctional ]-- -- high level tests between a client and server with fake ciphers.- tests_handshake = testGroup "Handshakes"- [ testProperty "Setup" (monadicIO prop_pipe_work)- , testProperty "Initiation" (monadicIO prop_handshake_initiate)- , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate)- , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate)- , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade)- , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures)- , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites)- , testProperty "Groups" (monadicIO prop_handshake_groups)- , testProperty "Elliptic curves" (monadicIO prop_handshake_ec)- , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback)- , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs)- , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage)- , testProperty "Client authentication" (monadicIO prop_handshake_client_auth)- , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage)- , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems)- , testProperty "Extended Master Secret (resumption)" (monadicIO prop_handshake_session_resumption_ems)- , testProperty "ALPN" (monadicIO prop_handshake_alpn)- , testProperty "SNI" (monadicIO prop_handshake_sni)- , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation)- , testProperty "Resumption" (monadicIO prop_handshake_session_resumption)- , testProperty "Custom DH" (monadicIO prop_handshake_dh)- , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full)- , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr)- , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk)- , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback)- , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0)- , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback)- , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length)- , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups)- , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth)- ]-- -- test concurrent reads and writes- tests_thread_safety = localOption (QuickCheckTests 10) $- testProperty "Thread safety" (monadicIO prop_thread_safety)
+ test/API.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module API where++import Control.Applicative+import Control.Monad+import Data.ByteString (ByteString)+import Data.Maybe+import Network.TLS+import Test.Hspec++checkCtxFinished :: Context -> IO ()+checkCtxFinished ctx = do+ mUnique <- getTLSUnique ctx+ mExporter <- getTLSExporter ctx+ when (isNothing (mUnique <|> mExporter)) $+ fail "unexpected channel binding"++recvDataAssert :: Context -> ByteString -> IO ()+recvDataAssert ctx expected = do+ got <- recvData ctx+ got `shouldBe` expected
+ test/Arbitrary.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Arbitrary where++import Control.Monad+import qualified Data.ByteString as B+import Data.List+import Data.Word+import Data.X509 (ExtKeyUsageFlag)+import Network.TLS+import Network.TLS.Extra.Cipher+import Network.TLS.Internal+import Test.QuickCheck++import Certificate+import PubKey++----------------------------------------------------------------++instance Arbitrary Version where+ arbitrary = elements [TLS12, TLS13]++instance Arbitrary ProtocolType where+ arbitrary =+ elements+ [ ProtocolType_ChangeCipherSpec+ , ProtocolType_Alert+ , ProtocolType_Handshake+ , ProtocolType_AppData+ ]++instance Arbitrary Header where+ arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ClientRandom where+ arbitrary = ClientRandom <$> genByteString 32++instance Arbitrary ServerRandom where+ arbitrary = ServerRandom <$> genByteString 32++instance Arbitrary Session where+ arbitrary = do+ i <- choose (1, 2) :: Gen Int+ case i of+ 2 -> Session . Just <$> genByteString 32+ _ -> return $ Session Nothing++instance {-# OVERLAPS #-} Arbitrary [HashAndSignatureAlgorithm] where+ arbitrary = shuffle supportedSignatureSchemes++instance Arbitrary DigitallySigned where+ arbitrary = DigitallySigned . unsafeHead <$> arbitrary <*> genByteString 32++instance Arbitrary ExtensionRaw where+ arbitrary =+ let arbitraryContent = choose (0, 40) >>= genByteString+ in ExtensionRaw . ExtensionID <$> arbitrary <*> arbitraryContent++instance Arbitrary CertificateType where+ arbitrary =+ elements+ [ CertificateType_RSA_Sign+ , CertificateType_DSA_Sign+ , CertificateType_ECDSA_Sign+ ]++instance Arbitrary CipherId where+ arbitrary = CipherId <$> arbitrary++instance Arbitrary Handshake where+ arbitrary =+ oneof+ [ arbitrary >>= \ver -> do+ ClientHello+ <$> ( CH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitraryCiphersIds+ <*> arbitraryCompressionIDs+ <*> arbitraryHelloExtensions ver+ )+ , arbitrary >>= \ver ->+ 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 . VerifyData <$> genByteString 12+ ]++instance Arbitrary Handshake13 where+ arbitrary =+ oneof+ [ arbitrary >>= \ver ->+ ServerHello13+ <$> ( SH TLS12+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> pure 0+ <*> arbitraryHelloExtensions ver+ )+ , NewSessionTicket13+ <$> arbitrary+ <*> arbitrary+ <*> (TicketNonce <$> genByteString 32) -- nonce+ <*> (SessionIDorTicket_ <$> genByteString 32) -- session ID+ <*> arbitrary+ , pure EndOfEarlyData13+ , EncryptedExtensions13 <$> arbitrary+ , CertRequest13+ <$> arbitraryCertReqContext+ <*> arbitrary+ , resize 2 (listOf arbitraryX509) >>= \certs ->+ Certificate13+ <$> arbitraryCertReqContext+ <*> return (CertificateChain_ (CertificateChain certs))+ <*> replicateM (length certs) arbitrary+ , CertVerify13+ <$> ( DigitallySigned . unsafeHead+ <$> arbitrary+ <*> genByteString 32+ )+ , Finished13 . VerifyData <$> genByteString 12+ , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested]+ ]++----------------------------------------------------------------++arbitraryCiphersIds :: Gen [CipherId]+arbitraryCiphersIds = map CipherId <$> (choose (0, 200) >>= vector)++arbitraryCompressionIDs :: Gen [Word8]+arbitraryCompressionIDs = choose (0, 200) >>= vector++someWords8 :: Int -> Gen [Word8]+someWords8 = vector++arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw]+arbitraryHelloExtensions _ver = arbitrary++arbitraryCertReqContext :: Gen B.ByteString+arbitraryCertReqContext = oneof [return B.empty, genByteString 32]++----------------------------------------------------------------++knownCiphers :: [Cipher]+knownCiphers = ciphersuite_all++instance Arbitrary Cipher where+ arbitrary = elements knownCiphers++knownVersions :: [Version]+knownVersions = [TLS13, TLS12]++arbitraryVersions :: Gen [Version]+arbitraryVersions = sublistOf knownVersions++-- for performance reason P521, FFDHE6144, FFDHE8192 are not tested+knownGroups, knownECGroups, knownFFGroups :: [Group]+knownECGroups = [P256, P384, X25519, X448]+knownFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096]+knownGroups = knownECGroups ++ knownFFGroups++defaultECGroup :: Group+defaultECGroup = P256 -- same as defaultECCurve++otherKnownECGroups :: [Group]+otherKnownECGroups = filter (/= defaultECGroup) knownECGroups++instance Arbitrary Group where+ arbitrary = elements knownGroups++instance {-# OVERLAPS #-} Arbitrary [Group] where+ arbitrary = sublistOf knownGroups++newtype EC = EC [Group] deriving (Show)++instance Arbitrary EC where+ arbitrary = EC <$> shuffle knownECGroups++newtype FFDHE = FFDHE [Group] deriving (Show)++instance Arbitrary FFDHE where+ arbitrary = FFDHE <$> shuffle knownFFGroups++isCredentialDSA :: (CertificateChain, PrivKey) -> Bool+isCredentialDSA (_, PrivKeyDSA _) = True+isCredentialDSA _ = False++----------------------------------------------------------------++arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle++arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachType' = do+ let (pubKey, privKey) = getGlobalRSAPair+ curveName = defaultECCurve+ (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName+ (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair+ (ed448Pub, ed448Priv) <- arbitraryEd448Pair+ mapM+ ( \(pub, priv) -> do+ cert <- arbitraryX509WithKey (pub, priv)+ return (CertificateChain [cert], priv)+ )+ [ (PubKeyRSA pubKey, PrivKeyRSA privKey)+ , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv)+ , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)+ , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)+ ]++arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle++arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachCurve' = do+ ecdsaPairs <-+ mapM+ ( \curveName -> do+ (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName+ return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv)+ )+ knownECCurves+ (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair+ (ed448Pub, ed448Priv) <- arbitraryEd448Pair+ mapM+ ( \(pub, priv) -> do+ cert <- arbitraryX509WithKey (pub, priv)+ return (CertificateChain [cert], priv)+ )+ $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)+ , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv)+ ]+ ++ ecdsaPairs++----------------------------------------------------------------++leafPublicKey :: CertificateChain -> Maybe PubKey+leafPublicKey (CertificateChain []) = Nothing+leafPublicKey (CertificateChain (leaf : _)) = Just (certPubKey $ getCertificate leaf)++isLeafRSA :: Maybe CertificateChain -> Bool+isLeafRSA chain = case chain >>= leafPublicKey of+ Just (PubKeyRSA _) -> True+ _ -> False++arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher])+arbitraryCipherPair connectVersion = do+ serverCiphers <-+ arbitrary+ `suchThat` (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs])+ clientCiphers <-+ arbitrary+ `suchThat` ( \cs ->+ or+ [ x `elem` serverCiphers+ && cipherAllowedForVersion connectVersion x+ | x <- cs+ ]+ )+ return (clientCiphers, serverCiphers)++----------------------------------------------------------------++instance {-# OVERLAPS #-} Arbitrary (ClientParams, ServerParams) where+ arbitrary = elements knownVersions >>= arbitraryPairParamsAt++----------------------------------------------------------------++data GGP = GGP [Group] [Group] deriving (Show)++instance Arbitrary GGP where+ arbitrary = arbitraryGroupPair++-- Pair of groups so that at least the default EC group P256 and one FF group+-- are in common. This makes DHE and ECDHE ciphers always compatible with+-- extension "Supported Elliptic Curves" / "Supported Groups".+arbitraryGroupPair :: Gen GGP+arbitraryGroupPair = do+ (serverECGroups, clientECGroups) <-+ arbitraryGroupPairWith defaultECGroup otherKnownECGroups+ serverGroups <- shuffle serverECGroups+ clientGroups <- shuffle clientECGroups+ return $ GGP clientGroups serverGroups+ where+ arbitraryGroupPairWith e es = do+ s <- sublistOf es+ c <- sublistOf es+ return (e : s, e : c)++----------------------------------------------------------------++arbitraryPairParams12 :: Gen (ClientParams, ServerParams)+arbitraryPairParams12 = arbitraryPairParamsAt TLS12++arbitraryPairParams13 :: Gen (ClientParams, ServerParams)+arbitraryPairParams13 = arbitraryPairParamsAt TLS13++arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams)+arbitraryPairParamsAt connectVersion = do+ (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion+ -- Select version lists containing connectVersion, as well as some other+ -- 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+ ]+ ]+ allowedVersionsFiltered = filter (<= connectVersion) allowedVersions+ -- Server or client is allowed to have versions > connectVersion, but not+ -- both simultaneously.+ filterSrv <- arbitrary+ let (clientAllowedVersions, serverAllowedVersions)+ | filterSrv = (allowedVersions, allowedVersionsFiltered)+ | otherwise = (allowedVersionsFiltered, allowedVersions)+ -- Generate version lists containing less than 127 elements, otherwise the+ -- "supported_versions" extension cannot be correctly serialized+ clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions+ serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions+ arbitraryPairParamsWithVersionsAndCiphers+ (clientVersions, serverVersions)+ (clientCiphers, serverCiphers)+ where+ listWithOthers :: a -> Int -> [a] -> Gen [a]+ listWithOthers fixedElement maxOthers others+ | maxOthers < 1 = return [fixedElement]+ | otherwise = sized $ \n -> do+ num <- choose (0, min n maxOthers)+ pos <- choose (0, num)+ prefix <- vectorOf pos $ elements others+ suffix <- vectorOf (num - pos) $ elements others+ return $ prefix ++ (fixedElement : suffix)++----------------------------------------------------------------++getConnectVersion :: (ClientParams, ServerParams) -> Version+getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver)+ where+ sver = supportedVersions (serverSupported sparams)+ cver = supportedVersions (clientSupported cparams)++isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool+isVersionEnabled ver (cparams, sparams) =+ (ver `elem` supportedVersions (serverSupported sparams))+ && (ver `elem` supportedVersions (clientSupported cparams))++arbitraryPairParamsWithVersionsAndCiphers+ :: ([Version], [Version])+ -> ([Cipher], [Cipher])+ -> Gen (ClientParams, ServerParams)+arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do+ secNeg <- arbitrary++ creds <- arbitraryCredentialsOfEachType+ GGP clientGroups serverGroups <- arbitraryGroupPair+ clientHashSignatures <- arbitrary+ serverHashSignatures <- arbitrary+ let serverState =+ defaultParamsServer+ { serverSupported =+ defaultSupported+ { supportedCiphers = serverCiphers+ , supportedVersions = serverVersions+ , supportedSecureRenegotiation = secNeg+ , supportedHashSignatures = serverHashSignatures+ , supportedGroups = serverGroups+ , supportedGroupsTLS13 = [serverGroups]+ }+ , serverShared = defaultShared{sharedCredentials = Credentials creds}+ }+ let clientState =+ (defaultParamsClient "" B.empty)+ { clientSupported =+ defaultSupported+ { supportedCiphers = clientCiphers+ , supportedVersions = clientVersions+ , supportedSecureRenegotiation = secNeg+ , supportedGroups = clientGroups+ , supportedHashSignatures = clientHashSignatures+ }+ , clientShared =+ defaultShared+ { sharedValidationCache =+ ValidationCache+ { cacheAdd = \_ _ _ -> return ()+ , cacheQuery = \_ _ _ -> return ValidationCachePass+ }+ }+ }+ return (clientState, serverState)++arbitraryClientCredential :: Version -> Gen Credential+arbitraryClientCredential _ = arbitraryCredentialsOfEachCurve' >>= elements++arbitraryRSACredentialWithUsage+ :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey)+arbitraryRSACredentialWithUsage usageFlags = do+ let (pubKey, privKey) = getGlobalRSAPair+ cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ())+ return (CertificateChain [cert], PrivKeyRSA privKey)++instance {-# OVERLAPS #-} Arbitrary (EMSMode, EMSMode) where+ arbitrary = (,) <$> gen <*> gen+ where+ gen = elements [NoEMS, AllowEMS, RequireEMS]++setEMSMode+ :: (EMSMode, EMSMode)+ -> (ClientParams, ServerParams)+ -> (ClientParams, ServerParams)+setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam')+ where+ clientParam' =+ clientParam+ { clientSupported =+ (clientSupported clientParam)+ { supportedExtendedMainSecret = cems+ }+ }+ serverParam' =+ serverParam+ { serverSupported =+ (serverSupported serverParam)+ { supportedExtendedMainSecret = sems+ }+ }++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
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Certificate (+ arbitraryX509,+ arbitraryX509WithKey,+ arbitraryX509WithKeyAndUsage,+ arbitraryDN,+ simpleCertificate,+ simpleX509,+ getSignatureALG,+ toPubKeyEC,+ toPrivKeyEC,+) where++import Crypto.Number.Serialize (i2ospOf_)+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Types as ECC+import Data.ASN1.OID+import qualified Data.ByteString as B+import Data.Hourglass+import Data.X509+import Test.QuickCheck++import PubKey++arbitraryDN :: Gen DistinguishedName+arbitraryDN = return $ DistinguishedName []++instance Arbitrary Date where+ arbitrary = do+ y <- choose (1971, 2035)+ m <- elements [January .. December]+ d <- choose (1, 30)+ return $ normalizeDate $ Date y m d++normalizeDate :: Date -> Date+normalizeDate d = timeConvert (timeConvert d :: Elapsed)++instance Arbitrary TimeOfDay where+ arbitrary = do+ h <- choose (0, 23)+ mi <- choose (0, 59)+ se <- choose (0, 59)+ let nsec = 0+ return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec++instance Arbitrary DateTime where+ arbitrary = DateTime <$> arbitrary <*> arbitrary++maxSerial :: Integer+maxSerial = 16777216++arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate+arbitraryCertificate usageFlags pubKey = do+ serial <- choose (0, maxSerial)+ subjectdn <- arbitraryDN+ validity <- (,) <$> arbitrary <*> arbitrary+ let sigalg = getSignatureALG pubKey+ return $+ Certificate+ { certVersion = 3+ , certSerial = serial+ , certSignatureAlg = sigalg+ , certIssuerDN = issuerdn+ , certSubjectDN = subjectdn+ , certValidity = validity+ , certPubKey = pubKey+ , certExtensions =+ Extensions $+ Just+ [ extensionEncode True $ ExtKeyUsage usageFlags+ ]+ }+ where+ issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")]++simpleCertificate :: PubKey -> Certificate+simpleCertificate pubKey =+ Certificate+ { certVersion = 3+ , certSerial = 0+ , certSignatureAlg = getSignatureALG pubKey+ , certIssuerDN = simpleDN+ , certSubjectDN = simpleDN+ , certValidity = (time1, time2)+ , certPubKey = pubKey+ , certExtensions =+ Extensions $+ Just+ [ extensionEncode True $+ ExtKeyUsage [KeyUsage_digitalSignature, KeyUsage_keyEncipherment]+ ]+ }+ where+ time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0)+ time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0)+ simpleDN = DistinguishedName []++simpleX509 :: PubKey -> SignedCertificate+simpleX509 pubKey =+ let cert = simpleCertificate pubKey+ sig = replicate 40 1+ sigalg = getSignatureALG pubKey+ (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert+ in signedExact++arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate+arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage++arbitraryX509WithKeyAndUsage+ :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate+arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do+ cert <- arbitraryCertificate usageFlags pubKey+ sig <- resize 40 $ listOf1 arbitrary+ let sigalg = getSignatureALG pubKey+ let (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert+ return signedExact++arbitraryX509 :: Gen SignedCertificate+arbitraryX509 = do+ let (pubKey, privKey) = getGlobalRSAPair+ arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey)++instance {-# OVERLAPS #-} Arbitrary [ExtKeyUsageFlag] where+ arbitrary = sublistOf knownKeyUsage++knownKeyUsage :: [ExtKeyUsageFlag]+knownKeyUsage =+ [ KeyUsage_digitalSignature+ , KeyUsage_keyEncipherment+ , KeyUsage_keyAgreement+ ]++getSignatureALG :: PubKey -> SignatureALG+getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA+getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA+getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC+getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519+getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448+getSignatureALG pubKey =+ error $ "getSignatureALG: unsupported public key: " ++ show pubKey++toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey+toPubKeyEC curveName key =+ let (x, y) = fromPoint $ ECDSA.public_q key+ pub = SerializedPoint bs+ bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y)+ bits = ECC.curveSizeBits (ECC.getCurveByName curveName)+ bytes = (bits + 7) `div` 8+ in PubKeyEC (PubKeyEC_Named curveName pub)++toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey+toPrivKeyEC curveName key =+ let priv = ECDSA.private_d key+ in PrivKeyEC (PrivKeyEC_Named curveName priv)++fromPoint :: ECC.Point -> (Integer, Integer)+fromPoint (ECC.Point x y) = (x, y)+fromPoint _ = error "fromPoint"
+ test/CiphersSpec.hs view
@@ -0,0 +1,76 @@+module CiphersSpec where++import qualified Data.ByteArray as BA+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Network.TLS.Cipher+import Network.TLS.Extra.Cipher+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++spec :: Spec+spec = do+ describe "ciphers" $ do+ prop "can ecnrypt/decrypt" $ \(BulkTest bulk key iv t additional) -> do+ let enc = bulkInit bulk BulkEncrypt key+ dec = bulkInit bulk BulkDecrypt key+ case (enc, dec) of+ (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF iv t+ (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF iv t additional+ (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF t+ _ -> return ()++block+ :: BulkBlock+ -> BulkBlock+ -> BulkIV+ -> ByteString+ -> IO ()+block e d iv t = do+ let (etxt, e_iv) = e iv t+ (dtxt, d_iv) = d iv etxt+ dtxt `shouldBe` t+ d_iv `shouldBe` e_iv++stream+ :: (ByteString -> (ByteString, BulkStream))+ -> (ByteString -> (ByteString, BulkStream))+ -> ByteString+ -> Expectation+stream e d t = (fst . d . fst . e) t `shouldBe` t++aead+ :: BulkAEAD+ -> BulkAEAD+ -> BulkNonce+ -> ByteString+ -> BulkAdditionalData+ -> Expectation+aead e d iv t additional = do+ let (encrypted, at) = e iv t additional+ (decrypted, at2) = d iv encrypted additional+ decrypted `shouldBe` t+ at `shouldBe` at2++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)++arbitraryText :: Bulk -> Gen B.ByteString+arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk)++data BulkTest+ = BulkTest Bulk BA.ScrubbedBytes B.ByteString B.ByteString B.ByteString+ deriving (Show, Eq)++instance Arbitrary BulkTest where+ arbitrary = do+ bulk <- cipherBulk `fmap` elements ciphersuite_all+ BulkTest bulk+ <$> arbitraryKey bulk+ <*> arbitraryIV bulk+ <*> arbitraryText bulk+ <*> arbitraryText bulk
+ 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
@@ -0,0 +1,39 @@+module EncodeSpec where++import Data.ByteString (ByteString)+import Network.TLS+import Network.TLS.Internal+import Test.Hspec+import Test.Hspec.QuickCheck++import Arbitrary ()++spec :: Spec+spec = do+ describe "encoder/decoder" $ do+ prop "can encode/decode Header" $ \x -> do+ decodeHeader (encodeHeader x) `shouldBe` Right x+ prop "can encode/decode Handshake" $ \x -> do+ decodeHs (encodeHandshake x) `shouldBe` Right x+ prop "can encode/decode Handshake13" $ \x -> do+ decodeHs13 (encodeHandshake13 x) `shouldBe` Right x++decodeHs :: ByteString -> Either TLSError Handshake+decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b+ where+ cp =+ CurrentParams+ { cParamsVersion = TLS12+ , cParamsKeyXchgType = Just CipherKeyExchange_RSA+ }++decodeHs13 :: ByteString -> Either TLSError Handshake13+decodeHs13 b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b++verifyResult :: (f -> r -> a) -> GetResult (f, r) -> a+verifyResult fn result =+ case result of+ GotPartial _ -> error "got partial"+ GotError e -> error ("got error: " ++ show e)+ GotSuccessRemaining _ _ -> error "got remaining byte left"+ GotSuccess (ty, content) -> fn ty content
+ test/HandshakeSpec.hs view
@@ -0,0 +1,1088 @@+{-# LANGUAGE OverloadedStrings #-}++module HandshakeSpec where++import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Data.List+import Data.Maybe+import Data.X509 (ExtKeyUsageFlag (..))+import Network.TLS+import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC+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 handshake with TLS 1.2 CBC" handshake_cbc+ prop "can re-negotiate with TLS 1.2" handshake12_renegotiation+ prop "can resume session with TLS 1.2" handshake12_session_resumption+ prop "can resume session ticket with TLS 1.2" handshake12_session_ticket+ prop "can handshake with TLS 1.3 Full" handshake13_full+ prop "can handshake with TLS 1.3 HRR" handshake13_hrr+ prop "can handshake with TLS 1.3 PSK" handshake13_psk+ prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket+ prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback+ prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt+ prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback+ prop "can handshake with TLS 1.3 EE" handshake13_ee_groups+ prop "can handshake with TLS 1.3 EC groups" handshake13_ec+ prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe+ prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth++--------------------------------------------------------------++pipe_work :: IO ()+pipe_work = do+ pipe <- newPipe+ _ <- runPipe pipe++ let bSize = 16+ n <- generate (choose (1, 32))++ let d1 = B.replicate (bSize * n) 40+ let d2 = B.replicate (bSize * n) 45++ d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1)+ d1' `shouldBe` d1++ d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2)+ d2' `shouldBe` d2++--------------------------------------------------------------++handshake_simple :: (ClientParams, ServerParams) -> IO ()+handshake_simple = runTLSSimple++--------------------------------------------------------------++newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP13 where+ arbitrary = CSP13 <$> arbitraryPairParams13++handshake13_simple :: CSP13 -> IO ()+handshake13_simple (CSP13 params) = runTLSSimple13 params hs+ where+ cgrps = supportedGroups $ clientSupported $ fst params+ sgrps = supportedGroups $ serverSupported $ snd params+ hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest++--------------------------------------------------------------++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_client_key_usage :: [ExtKeyUsageFlag] -> IO ()+handshake_client_key_usage usageFlags = do+ (clientParam, serverParam) <- generate arbitrary+ cred <- generate $ arbitraryRSACredentialWithUsage usageFlags+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = \_ -> return CertificateUsageAccept+ }+ }+ shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags+ if shouldSucceed+ then runTLSSimple (clientParam', serverParam')+ else runTLSFailure (clientParam', serverParam') handshake handshake++--------------------------------------------------------------++handshake_client_auth :: (ClientParams, ServerParams) -> IO ()+handshake_client_auth (clientParam, serverParam) = do+ let clientVersions = supportedVersions $ clientSupported clientParam+ serverVersions = supportedVersions $ serverSupported serverParam+ version = maximum (clientVersions `intersect` serverVersions)+ cred <- generate (arbitraryClientCredential version)+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = validateChain cred+ }+ }+ runTLSSimple (clientParam', serverParam')+ where+ validateChain cred chain+ | chain == fst cred = return CertificateUsageAccept+ | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)++handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO ()+handshake_client_auth_fail (clientParam, serverParam) = do+ let clientVersions = supportedVersions $ clientSupported clientParam+ serverVersions = supportedVersions $ serverSupported serverParam+ version = maximum (clientVersions `intersect` serverVersions)+ cred <- generate (arbitraryClientCredential version)+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = validateChain cred+ }+ }+ runTLSFailure (clientParam', serverParam') handshake handshake+ where+ validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA)++--------------------------------------------------------------++handshake_ems :: (EMSMode, EMSMode) -> IO ()+handshake_ems (cems, sems) = do+ params <- generate arbitrary+ let params' = setEMSMode (cems, sems) params+ version = getConnectVersion params'+ emsVersion = version >= TLS10 && version <= TLS12+ use = cems /= NoEMS && sems /= NoEMS+ require = cems == RequireEMS || sems == RequireEMS+ p info = infoExtendedMainSecret info == (emsVersion && use)+ if emsVersion && require && not use+ then runTLSFailure params' handshake handshake+ else runTLSPredicate params' (maybe False p)++newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show)++instance Arbitrary CompatEMS where+ arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible)+ where+ compatible (NoEMS, RequireEMS) = False+ compatible (RequireEMS, NoEMS) = False+ compatible _ = True++handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO ()+handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ plainParams <- generate arbitrary+ let params =+ setEMSMode ems $+ setPairParamsSessionManagers sessionManagers plainParams++ runTLSSimple params++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 =+ setEMSMode ems2 $+ setPairParamsSessionResuming (fromJust sessionParams) params++ let version = getConnectVersion params2+ emsVersion = version >= TLS10 && version <= TLS12++ if emsVersion && use ems && not (use ems2)+ then runTLSFailure params2 handshake handshake+ else do+ runTLSSimple params2+ mSessionParams2 <- readClientSessionRef sessionRefs+ let sameSession = sessionParams == mSessionParams2+ sameUse = use ems == use ems2+ when emsVersion (sameSession `shouldBe` sameUse)+ where+ use (NoEMS, _) = False+ use (_, NoEMS) = False+ use _ = True++--------------------------------------------------------------++handshake_alpn :: (ClientParams, ServerParams) -> IO ()+handshake_alpn (clientParam, serverParam) = do+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onSuggestALPN = return $ Just ["h2", "http/1.1"]+ }+ }+ serverParam' =+ serverParam+ { serverHooks =+ (serverHooks serverParam)+ { onALPNClientSuggest = Just alpn+ }+ }+ params' = (clientParam', serverParam')+ runTLSSuccess params' hsClient hsServer+ where+ hsClient ctx = do+ handshake ctx+ proto <- getNegotiatedProtocol ctx+ proto `shouldBe` Just "h2"+ hsServer ctx = do+ handshake ctx+ proto <- getNegotiatedProtocol ctx+ proto `shouldBe` Just "h2"+ alpn xs+ | "h2" `elem` xs = return "h2"+ | otherwise = return "http/1.1"++handshake_sni :: (ClientParams, ServerParams) -> IO ()+handshake_sni (clientParam, serverParam) = do+ ref <- newIORef Nothing+ let clientParam' =+ clientParam+ { clientServerIdentification = (serverName, "")+ }+ serverParam' =+ serverParam+ { serverHooks =+ (serverHooks serverParam)+ { onServerNameIndication = onSNI ref+ }+ }+ params' = (clientParam', serverParam')+ runTLSSuccess params' hsClient hsServer+ receivedName <- readIORef ref+ receivedName `shouldBe` Just (Just serverName)+ where+ hsClient ctx = do+ handshake ctx+ msni <- getClientSNI ctx+ expectMaybe "C: SNI should be Just" serverName msni+ hsServer ctx = do+ handshake ctx+ msni <- getClientSNI ctx+ expectMaybe "S: SNI should be Just" serverName msni+ onSNI ref name = do+ mx <- readIORef ref+ mx `shouldBe` Nothing+ writeIORef ref (Just name)+ return (Credentials [])+ serverName = "haskell.org"++--------------------------------------------------------------++newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP12 where+ arbitrary = CSP12 <$> arbitraryPairParams12++handshake12_renegotiation :: CSP12 -> IO ()+handshake12_renegotiation (CSP12 (cparams, sparams)) = do+ renegDisabled <- generate arbitrary+ let sparams' =+ sparams+ { serverSupported =+ (serverSupported sparams)+ { supportedClientInitiatedRenegotiation = not renegDisabled+ }+ }+ if renegDisabled+ then runTLSFailure (cparams, sparams') hsClient hsServer+ else runTLSSimple (cparams, sparams')+ where+ hsClient ctx = handshake ctx >> handshake ctx+ -- recvData receives the alert from the second handshake+ hsServer ctx = handshake ctx >> void (recvData ctx)++handshake12_session_resumption :: CSP12 -> IO ()+handshake12_session_resumption (CSP12 plainParams) = do+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers plainParams++ runTLSSimple params++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSPredicate params2 (maybe False infoTLS12Resumption)++handshake12_session_ticket :: CSP12 -> IO ()+handshake12_session_ticket (CSP12 plainParams) = do+ sessionRefs <- twoSessionRefs+ let sessionManagers0 = twoSessionManagers sessionRefs+ sessionManagers = (fst sessionManagers0, oneSessionTicket)++ let params = setPairParamsSessionManagers sessionManagers plainParams++ runTLSSimple params++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSPredicate params2 (maybe False infoTLS12Resumption)++--------------------------------------------------------------++handshake13_full :: CSP13 -> IO ()+handshake13_full (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13 params FullHandshake++handshake13_hrr :: CSP13 -> IO ()+handshake13_hrr (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13 params HelloRetryRequest++handshake13_psk :: CSP13 -> IO ()+handshake13_psk (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13 params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13 params2 PreSharedKey++handshake13_psk_ticket :: CSP13 -> IO ()+handshake13_psk_ticket (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers0 = twoSessionManagers sessionRefs+ sessionManagers = (fst sessionManagers0, oneSessionTicket)++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13 params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13 params2 PreSharedKey++handshake13_psk_fallback :: CSP13 -> IO ()+handshake13_psk_fallback (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers =+ [ cipher13_AES_128_GCM_SHA256+ , cipher13_AES_128_CCM_SHA256+ ]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13 params HelloRetryRequest++ -- resumption fails because GCM cipher is not supported anymore, full+ -- handshake is not possible because X25519 has been removed, so we are+ -- back with P256 after hello retry+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params+ srv2' =+ srv2{serverSupported = svrSupported'}+ svrSupported' =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_CCM_SHA256]+ , supportedGroups = [P256]+ , supportedGroupsTLS13 = [[P256]]+ }++ runTLSSimple13 (cli2, srv2') HelloRetryRequest++handshake13_0rtt :: CSP13 -> IO ()+handshake13_0rtt (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ cliHooks =+ defaultClientHooks+ { onSuggestALPN = return $ Just ["h2"]+ }+ svrHooks =+ defaultServerHooks+ { onALPNClientSuggest = Just (return . unsafeHead)+ }+ params0 =+ ( cli+ { clientSupported = cliSupported+ , clientHooks = cliHooks+ }+ , srv+ { serverSupported = svrSupported+ , serverHooks = svrHooks+ , serverEarlyDataSize = 2048+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13 params HelloRetryRequest+ runTLS0rtt params sessionRefs+ runTLS0rtt params sessionRefs+ where+ runTLS0rtt params sessionRefs = do+ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ clearClientSessionRef sessionRefs+ earlyData <- B.pack <$> generate (someWords8 256)+ let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ params2 = (pc{clientUseEarlyData = True}, ps)++ runTLS0RTT params2 RTT0 earlyData++handshake13_0rtt_fallback :: CSP13 -> IO ()+handshake13_0rtt_fallback (CSP13 (cli, srv)) = do+ group0 <- generate $ elements [P256, X25519]+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [group0]+ , supportedGroupsTLS13 = [[group0]]+ }+ params =+ ( cli{clientSupported = cliSupported}+ , srv+ { serverSupported = svrSupported+ , serverEarlyDataSize = 1024+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params0 = setPairParamsSessionManagers sessionManagers params++ let mode = if group0 == P256 then FullHandshake else HelloRetryRequest+ runTLSSimple13 params0 mode++ -- and resume+ mSessionParams <- readClientSessionRef sessionRefs+ case mSessionParams of+ Nothing -> expectationFailure "session params: Just is expected"+ Just sessionParams -> do+ earlyData <- B.pack <$> generate (someWords8 256)+ group1 <- generate $ elements [P256, X25519]+ let (pc, ps) = setPairParamsSessionResuming sessionParams params0+ svrSupported1 =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [group1]+ , supportedGroupsTLS13 = [[group1]]+ }+ params1 =+ ( pc{clientUseEarlyData = True}+ , ps+ { serverEarlyDataSize = 0+ , serverSupported = svrSupported1+ }+ )+ -- C: [P256, X25519]+ -- S: [group0]+ -- C: [P256, X25519]+ -- S: [group1]+ if group0 == group1+ -- 0-RTT is not allowed, so fallback to PreSharedKey+ then runTLS0RTT params1 PreSharedKey earlyData+ -- HRR but not allowed for 0-RTT+ else runTLSFailure params1 (tlsClient earlyData) tlsServer+ where+ tlsClient earlyData ctx = do+ handshake ctx+ sendData ctx $ L.fromStrict earlyData+ _ <- recvData ctx+ bye ctx+ tlsServer ctx = do+ handshake ctx+ _ <- recvData ctx+ bye ctx++handshake13_ee_groups :: CSP13 -> IO ()+handshake13_ee_groups (CSP13 (cli, srv)) = do+ let -- The client prefers P256+ cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]}+ -- The server prefers X25519+ svrSupported =+ (serverSupported srv)+ { supportedGroups = [X25519, P256]+ , supportedGroupsTLS13 = [[X25519, P256]]+ }+ params =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ (_, serverMessages) <- runTLSCapture13 params+ -- The server should tell X25519 in supported_groups in EE to 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++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"++expectJust :: String -> Maybe a -> Expectation+expectJust tag mx = case mx of+ Nothing -> expectationFailure tag+ Just _ -> return ()
+ test/PipeChan.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RecordWildCards #-}++-- create a similar concept than a unix pipe.+module PipeChan (+ PipeChan (..),+ newPipe,+ runPipe,+ readPipeC,+ readPipeS,+ writePipeC,+ writePipeS,+) where++import Control.Concurrent+import Control.Monad (forever)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.IORef++----------------------------------------------------------------++-- | represent a unidirectional pipe with a buffered read channel and+-- a write channel+data UniPipeChan = UniPipeChan+ { getReadUniPipe :: Chan ByteString+ , getWriteUniPipe :: Chan ByteString+ }++newUniPipeChan :: IO UniPipeChan+newUniPipeChan = UniPipeChan <$> newChan <*> newChan++runUniPipe :: UniPipeChan -> IO ThreadId+runUniPipe UniPipeChan{..} =+ forkIO $+ forever $+ readChan getReadUniPipe >>= writeChan getWriteUniPipe++----------------------------------------------------------------++-- | Represent a bidirectional pipe with 2 nodes A and B+data PipeChan = PipeChan+ { fromC :: IORef ByteString+ , fromS :: IORef ByteString+ , c2s :: UniPipeChan+ , s2c :: UniPipeChan+ }++newPipe :: IO PipeChan+newPipe =+ PipeChan+ <$> newIORef B.empty+ <*> newIORef B.empty+ <*> newUniPipeChan+ <*> newUniPipeChan++runPipe :: PipeChan -> IO (ThreadId, ThreadId)+runPipe PipeChan{..} = (,) <$> runUniPipe c2s <*> runUniPipe s2c++readPipeC :: PipeChan -> Int -> IO ByteString+readPipeC PipeChan{..} sz = readBuffered fromS (getWriteUniPipe s2c) sz++writePipeC :: PipeChan -> ByteString -> IO ()+writePipeC PipeChan{..} = writeChan $ getWriteUniPipe c2s++readPipeS :: PipeChan -> Int -> IO ByteString+readPipeS PipeChan{..} sz = readBuffered fromC (getWriteUniPipe c2s) sz++writePipeS :: PipeChan -> ByteString -> IO ()+writePipeS PipeChan{..} = writeChan $ getReadUniPipe s2c++-- helper to read buffered data.+readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString+readBuffered ref chan sz = do+ left <- readIORef ref+ if B.length left >= sz+ then do+ let (ret, nleft) = B.splitAt sz left+ writeIORef ref nleft+ return ret+ else do+ let newSize = sz - B.length left+ newData <- readChan chan+ writeIORef ref newData+ remain <- readBuffered ref chan newSize+ return (left `B.append` remain)
+ test/PubKey.hs view
@@ -0,0 +1,123 @@+module PubKey (+ arbitraryRSAPair,+ arbitraryDSAPair,+ arbitraryECDSAPair,+ arbitraryEd25519Pair,+ arbitraryEd448Pair,+ globalRSAPair,+ getGlobalRSAPair,+ knownECCurves,+ defaultECCurve,+ dsaParams,+ rsaParams,+) where++import Control.Concurrent.MVar+import Crypto.Error+import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.PubKey.ECC.Types as ECC+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.RSA as RSA+import Crypto.Random+import qualified Data.ByteString as B+import System.IO.Unsafe+import Test.QuickCheck++arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey)+arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary+ where+ rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey)+ rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG++arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey)+arbitraryRSAPairWithRNG = RSA.generate 256 0x10001++{-# NOINLINE globalRSAPair #-}+globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey)+globalRSAPair = unsafePerformIO $ do+ drg <- drgNew+ newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG)++{-# NOINLINE getGlobalRSAPair #-}+getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey)+getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair)++rsaParams :: (RSA.PublicKey, RSA.PrivateKey)+rsaParams = (pub, priv)+ where+ priv =+ RSA.PrivateKey+ { RSA.private_pub = pub+ , RSA.private_d = d+ , RSA.private_p = 0+ , RSA.private_q = 0+ , RSA.private_dP = 0+ , RSA.private_dQ = 0+ , RSA.private_qinv = 0+ }+ pub =+ RSA.PublicKey+ { RSA.public_size = 1024 `div` 8+ , RSA.public_n = n+ , RSA.public_e = e+ }+ n =+ 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7+ e = 0x10001+ d =+ 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481++dsaParams :: DSA.Params+dsaParams =+ DSA.Params+ { DSA.params_p =+ 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb+ , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b+ , DSA.params_g =+ 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff+ }++arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey)+arbitraryDSAPair = do+ priv <- choose (1, DSA.params_q dsaParams)+ let pub = DSA.calculatePublic dsaParams priv+ return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv)++-- for performance reason P521 is not tested+knownECCurves :: [ECC.CurveName]+knownECCurves =+ [ ECC.SEC_p256r1+ , ECC.SEC_p384r1+ , ECC.SEC_p521r1+ ]++defaultECCurve :: ECC.CurveName+defaultECCurve = ECC.SEC_p256r1++arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey)+arbitraryECDSAPair curveName = do+ d <- choose (1, n - 1)+ let p = ECC.pointBaseMul curve d+ return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d)+ where+ curve = ECC.getCurveByName curveName+ n = ECC.ecc_n . ECC.common_curve $ curve++arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey)+arbitraryEd25519Pair = do+ bytes <- vectorOf 32 arbitrary+ let priv = fromCryptoPassed $ Ed25519.secretKey (B.pack bytes)+ return (Ed25519.toPublic priv, priv)++arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey)+arbitraryEd448Pair = do+ bytes <- vectorOf 57 arbitrary+ let priv = fromCryptoPassed $ Ed448.secretKey (B.pack bytes)+ return (Ed448.toPublic priv, priv)++fromCryptoPassed :: CryptoFailable a -> a+fromCryptoPassed (CryptoPassed x) = x+fromCryptoPassed _ = error "fromCryptoPassed"
+ test/Run.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Run (+ runTLS,+ runTLSSimple,+ runTLSPredicate,+ runTLSSimple13,+ runTLSSimple13ECH,+ runTLS0RTT,+ runTLS0RTTech,+ runTLSSimpleKeyUpdate,+ runTLSCaptureFail,+ runTLSCapture13,+ runTLSSuccess,+ runTLSFailure,+ expectMaybe,+ newPairContext,+ withDataPipe,+ byeBye,+) where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Network.TLS+import System.Timeout+import Test.Hspec+import Test.QuickCheck++import API+import Arbitrary+import PipeChan++type ClinetWithInput = Chan ByteString -> Context -> IO ()+type ServerWithOutput = Context -> Chan [ByteString] -> IO ()++----------------------------------------------------------------++runTLS+ :: (ClientParams, ServerParams)+ -> ClinetWithInput+ -> ServerWithOutput+ -> IO ()+runTLS = runTLSN 1++runTLSN+ :: Int+ -> (ClientParams, ServerParams)+ -> ClinetWithInput+ -> ServerWithOutput+ -> IO ()+runTLSN n params tlsClient tlsServer = do+ inputChan <- newChan+ outputChan <- newChan+ -- generate some data to send+ ds <- replicateM n $ B.pack <$> generate (someWords8 256)+ forM_ ds $ writeChan inputChan+ -- run client and server+ withPairContext params $ \(cCtx, sCtx) ->+ concurrently_ (server sCtx outputChan) (client inputChan cCtx)+ -- read result+ mDs <- timeout 1000000 $ readChan outputChan -- 60 sec+ expectMaybe "timeout" ds mDs+ where+ server sCtx outputChan =+ E.catch+ (tlsServer sCtx outputChan)+ (printAndRaise "S: " (serverSupported $ snd params))+ client inputChan cCtx =+ E.catch+ (tlsClient inputChan cCtx)+ (printAndRaise "C: " (clientSupported $ fst params))+ printAndRaise :: String -> Supported -> E.SomeException -> IO ()+ printAndRaise s supported e = do+ putStrLn $+ s+ ++ " exception: "+ ++ show e+ ++ ", supported: "+ ++ show supported+ E.throwIO e++----------------------------------------------------------------++runTLSSimple :: (ClientParams, ServerParams) -> IO ()+runTLSSimple params = runTLSPredicate params (const True)++runTLSPredicate+ :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> IO ()+runTLSPredicate params p = runTLSSuccess params hsClient hsServer+ where+ hsClient ctx = do+ handshake ctx+ checkInfoPredicate ctx+ hsServer ctx = do+ handshake ctx+ checkInfoPredicate ctx+ checkInfoPredicate ctx = do+ minfo <- contextGetInformation ctx+ unless (p minfo) $+ fail ("unexpected information: " ++ show minfo)++----------------------------------------------------------------++runTLSSimple13+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> IO ()+runTLSSimple13 params mode =+ runTLSSuccess params hsClient hsServer+ where+ hsClient ctx = do+ handshake ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "C: mode should be Just" mode mmode+ hsServer ctx = do+ handshake ctx+ 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+ -> ByteString+ -> IO ()+runTLS0RTT 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+ bye ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "C: mode should be Just" mode mmode+ 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+ 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 = []++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+ 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+ 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+ sRef <- newIORef []+ cRef <- newIORef []+ runTLSSuccess 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+ hsServer ref ctx = do+ installHook ctx ref+ handshake ctx+ installHook ctx ref =+ let recv hss = modifyIORef ref (hss :) >> return hss+ in contextHookSetHandshake13Recv ctx recv++runTLSSimpleKeyUpdate :: (ClientParams, ServerParams) -> IO ()+runTLSSimpleKeyUpdate params = runTLSN 3 params tlsClient tlsServer+ where+ tlsClient queue ctx = do+ handshake ctx+ d0 <- readChan queue+ sendData ctx (L.fromChunks [d0])+ d1 <- readChan queue+ sendData ctx (L.fromChunks [d1])+ req <- generate $ elements [OneWay, TwoWay]+ _ <- updateKey ctx req+ d2 <- readChan queue+ sendData ctx (L.fromChunks [d2])+ checkCtxFinished ctx+ bye ctx+ tlsServer ctx queue = do+ handshake ctx+ d0 <- recvData ctx+ req <- generate $ elements [OneWay, TwoWay]+ _ <- updateKey ctx req+ d1 <- recvData ctx+ d2 <- recvData ctx+ writeChan queue [d0, d1, d2]+ checkCtxFinished ctx+ bye ctx++----------------------------------------------------------------++runTLSSuccess+ :: (ClientParams, ServerParams)+ -> (Context -> IO ())+ -> (Context -> IO ())+ -> IO ()+runTLSSuccess params hsClient hsServer = runTLS params tlsClient tlsServer+ where+ tlsClient queue ctx = do+ hsClient ctx+ d <- readChan queue+ sendData ctx (L.fromChunks [d])+ checkCtxFinished ctx+ bye ctx+ tlsServer ctx queue = do+ hsServer ctx+ d <- recvData ctx+ writeChan queue [d]+ checkCtxFinished ctx+ bye ctx++runTLSFailure+ :: (ClientParams, ServerParams)+ -> (Context -> IO c)+ -> (Context -> IO s)+ -> IO ()+runTLSFailure params hsClient hsServer =+ withPairContext params $ \(cCtx, sCtx) ->+ concurrently_ (tlsServer sCtx) (tlsClient cCtx)+ where+ tlsClient ctx = hsClient ctx `shouldThrow` anyTLSException+ tlsServer ctx = hsServer ctx `shouldThrow` anyTLSException++anyTLSException :: Selector TLSException+anyTLSException = const True++----------------------------------------------------------------++debug :: Bool+debug = False++withPairContext+ :: (ClientParams, ServerParams) -> ((Context, Context) -> IO ()) -> IO ()+withPairContext params body =+ E.bracket+ (newPairContext params)+ (\((t1, t2), _) -> killThread t1 >> killThread t2)+ (\(_, ctxs) -> body ctxs)++newPairContext+ :: (ClientParams, ServerParams)+ -> IO ((ThreadId, ThreadId), (Context, Context))+newPairContext (cParams, sParams) = do+ pipe <- newPipe+ tids <- runPipe pipe+ let noFlush = return ()+ let noClose = return ()++ 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++ contextHookSetLogging cCtx' (logging "client: ")+ contextHookSetLogging sCtx' (logging "server: ")++ return (tids, (cCtx', sCtx'))+ where+ logging pre =+ if debug+ then+ defaultLogging+ { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++)+ , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++)+ }+ 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/Session.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Session (+ readClientSessionRef,+ clearClientSessionRef,+ twoSessionRefs,+ twoSessionManagers,+ setPairParamsSessionManagers,+ setPairParamsSessionResuming,+ oneSessionTicket,+) where++import Codec.Serialise+import Control.Monad+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Network.TLS+import Network.TLS.Internal++----------------------------------------------------------------++readClientSessionRef :: (IORef (Maybe c), IORef (Maybe s)) -> IO (Maybe c)+readClientSessionRef refs = readIORef (fst refs)++clearClientSessionRef :: (IORef (Maybe c), IORef (Maybe s)) -> IO ()+clearClientSessionRef refs = writeIORef (fst refs) Nothing++twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server))+twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing++-- | simple session manager to store one session id and session data for a single thread.+-- a Real concurrent session manager would use an MVar and have multiples items.+oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager+oneSessionManager ref =+ 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+ , sessionInvalidate = \_ -> return ()+ , sessionUseTicket = False+ }+ where+ maybeResume onlyOnce myId (Just (sid, sdata))+ | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata)+ maybeResume _ _ _ = return Nothing++twoSessionManagers+ :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData)))+ -> (SessionManager, SessionManager)+twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef)++setPairParamsSessionManagers+ :: (SessionManager, SessionManager)+ -> (ClientParams, ServerParams)+ -> (ClientParams, ServerParams)+setPairParamsSessionManagers (clientManager, serverManager) (clientParams, serverParams) = (nc, ns)+ where+ nc =+ clientParams+ { clientShared = updateSessionManager clientManager $ clientShared clientParams+ }+ ns =+ serverParams+ { serverShared = updateSessionManager serverManager $ serverShared serverParams+ }+ updateSessionManager manager shared = shared{sharedSessionManager = manager}++----------------------------------------------------------------++setPairParamsSessionResuming+ :: (SessionID, SessionData)+ -> (ClientParams, ServerParams)+ -> (ClientParams, ServerParams)+setPairParamsSessionResuming sessionStuff (clientParams, serverParams) =+ ( clientParams{clientWantSessionResume = Just sessionStuff}+ , serverParams+ )++oneSessionTicket :: SessionManager+oneSessionTicket =+ noSessionManager+ { sessionResume = resume+ , sessionResumeOnlyOnce = resume+ , sessionEstablish = \_ dat -> return $ Just $ L.toStrict $ serialise dat+ , sessionInvalidate = \_ -> return ()+ , sessionUseTicket = True+ }++resume :: Ticket -> IO (Maybe SessionData)+resume ticket+ | isTicket ticket = return $ Just $ deserialise $ L.fromStrict ticket+ | otherwise = return Nothing
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/ThreadSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module ThreadSpec where++import Control.Concurrent+import Control.Concurrent.Async+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.Foldable (traverse_)+import Network.TLS+import Test.Hspec+import Test.Hspec.QuickCheck++import API+import Arbitrary ()+import Run++spec :: Spec+spec = do+ describe "thread safety" $ do+ prop "can read/write concurrently" $ \params ->+ runTLS params tlsClient tlsServer++tlsClient :: Chan ByteString -> Context -> IO ()+tlsClient queue ctx = do+ handshake ctx+ runReaderWriters ctx "server-value" "client-value"+ d <- readChan queue+ sendData ctx (L.fromChunks [d])+ checkCtxFinished ctx+ bye ctx++tlsServer :: Context -> Chan [ByteString] -> IO ()+tlsServer ctx queue = do+ handshake ctx+ runReaderWriters ctx "client-value" "server-value"+ d <- recvData ctx+ writeChan queue [d]+ checkCtxFinished ctx+ bye ctx++runReaderWriters :: Context -> ByteString -> L.ByteString -> IO ()+runReaderWriters ctx r w =+ -- run concurrently 10 readers and 10 writers on the same context+ let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w]+ in runConcurrently $ traverse_ Concurrently workers
tls.cabal view
@@ -1,189 +1,280 @@-Name: tls-Version: 1.6.0-Description:- Native Haskell TLS and SSL protocol implementation for server and client.- .- This provides a high-level implementation of a sensitive security protocol,- eliminating a common set of security issues through the use of the advanced- type system, high level constructions and common Haskell features.- .- Currently implement the TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 protocol,- and support RSA and Ephemeral (Elliptic curve and regular) Diffie Hellman key exchanges,- and many extensions.- .- Some debug tools linked with tls, are available through the- <http://hackage.haskell.org/package/tls-debug/>.-License: BSD3-License-file: LICENSE-Copyright: Vincent Hanquez <vincent@snarc.org>-Author: Vincent Hanquez <vincent@snarc.org>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-Synopsis: TLS/SSL protocol native implementation (Server and Client)-Build-Type: Simple-Category: Network-stability: experimental-Cabal-Version: >=1.10-Homepage: http://github.com/vincenthz/hs-tls-extra-source-files: Tests/*.hs- CHANGELOG.md+cabal-version: >=1.10+name: tls+version: 2.4.3+license: BSD3+license-file: LICENSE+copyright: Vincent Hanquez <vincent@snarc.org>+maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+author: Vincent Hanquez <vincent@snarc.org>+homepage: https://github.com/haskell-tls/hs-tls+synopsis: TLS protocol native implementation+description:+ Native Haskell TLS 1.2/1.3 protocol implementation for servers and clients. -Flag compat- Description: Accept SSLv2 client hello for beginning SSLv3 / TLS handshake- Default: True+category: Network+build-type: Simple+extra-source-files:+ test/*.hs+ CHANGELOG.md -Flag network- Description: Use the base network library- Default: True+source-repository head+ type: git+ location: https://github.com/haskell-tls/hs-tls+ subdir: tls -Flag hans- Description: Use the Haskell Network Stack (HaNS)- Default: False+flag devel+ description: Development commands+ default: False -Library- Default-Language: Haskell2010- Build-Depends: base >= 4.9 && < 5- , mtl >= 2.2.1- , transformers- , cereal >= 0.5.3- , bytestring- , data-default-class- -- crypto related- , memory >= 0.14.6- , cryptonite >= 0.27- -- certificate related- , asn1-types >= 0.2.0- , asn1-encoding- , x509 >= 1.7.5- , x509-store >= 1.6- , x509-validation >= 1.6.5- , async >= 2.0- , hourglass- if flag(network)- Build-Depends: network >= 2.4.0.0- cpp-options: -DINCLUDE_NETWORK- if flag(hans)- Build-Depends: hans- cpp-options: -DINCLUDE_HANS- Exposed-modules: Network.TLS- Network.TLS.Cipher- Network.TLS.Compression- Network.TLS.Internal- Network.TLS.Extra- Network.TLS.Extra.Cipher- Network.TLS.Extra.FFDHE- Network.TLS.QUIC- other-modules: Network.TLS.Cap- Network.TLS.Struct- Network.TLS.Struct13- Network.TLS.Core- Network.TLS.Context- Network.TLS.Context.Internal- Network.TLS.Credentials- Network.TLS.Backend- Network.TLS.Crypto- Network.TLS.Crypto.DH- Network.TLS.Crypto.IES- Network.TLS.Crypto.Types- Network.TLS.ErrT- Network.TLS.Extension- Network.TLS.Handshake- Network.TLS.Handshake.Certificate- Network.TLS.Handshake.Client- Network.TLS.Handshake.Common- 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.Signature- Network.TLS.Handshake.State- Network.TLS.Handshake.State13- Network.TLS.Hooks- Network.TLS.IO- Network.TLS.Imports- Network.TLS.KeySchedule- Network.TLS.MAC- Network.TLS.Measurement- Network.TLS.Packet- Network.TLS.Packet13- Network.TLS.Parameters- Network.TLS.PostHandshake- Network.TLS.Record- Network.TLS.Record.Disengage- Network.TLS.Record.Engage- Network.TLS.Record.Layer- Network.TLS.Record.Reading- Network.TLS.Record.Writing- 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.Util- Network.TLS.Util.ASN1- Network.TLS.Util.Serialization- Network.TLS.Types- Network.TLS.Wire- Network.TLS.X509- ghc-options: -Wall- if flag(compat)- cpp-options: -DSSLV2_COMPATIBLE+library+ exposed-modules:+ Network.TLS+ Network.TLS.Cipher+ Network.TLS.Compression+ Network.TLS.Internal+ Network.TLS.Extra+ Network.TLS.Extra.Cipher+ Network.TLS.Extra.CipherCBC+ Network.TLS.Extra.FFDHE+ Network.TLS.QUIC -Test-Suite test-tls- Default-Language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: Tests- Main-is: Tests.hs- other-modules: Certificate- Ciphers- Connection- Marshalling- PipeChan- PubKey- Build-Depends: base >= 3 && < 5- , async >= 2.0- , data-default-class- , tasty- , tasty-quickcheck- , tls- , QuickCheck- , cryptonite- , bytestring- , asn1-types- , x509- , x509-validation- , hourglass- ghc-options: -Wall -fno-warn-unused-imports+ other-modules:+ Network.TLS.Struct+ Network.TLS.Struct13+ Network.TLS.Core+ Network.TLS.Context+ Network.TLS.Context.Internal+ Network.TLS.Credentials+ Network.TLS.Backend+ Network.TLS.Crypto+ Network.TLS.Crypto.DH+ Network.TLS.Crypto.IES+ Network.TLS.Crypto.Types+ Network.TLS.ErrT+ Network.TLS.Error+ Network.TLS.Extension+ Network.TLS.Handshake+ Network.TLS.Handshake.Certificate+ Network.TLS.Handshake.Client+ Network.TLS.Handshake.Client.ClientHello+ Network.TLS.Handshake.Client.Common+ Network.TLS.Handshake.Client.ServerHello+ Network.TLS.Handshake.Client.TLS12+ Network.TLS.Handshake.Client.TLS13+ Network.TLS.Handshake.Common+ Network.TLS.Handshake.Common13+ Network.TLS.Handshake.Control+ Network.TLS.Handshake.Key+ Network.TLS.Handshake.Random+ Network.TLS.Handshake.Server+ Network.TLS.Handshake.Server.ClientHello+ Network.TLS.Handshake.Server.ClientHello12+ Network.TLS.Handshake.Server.ClientHello13+ Network.TLS.Handshake.Server.Common+ Network.TLS.Handshake.Server.ServerHello12+ Network.TLS.Handshake.Server.ServerHello13+ Network.TLS.Handshake.Server.TLS12+ Network.TLS.Handshake.Server.TLS13+ 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+ Network.TLS.Measurement+ Network.TLS.Packet+ Network.TLS.Packet13+ Network.TLS.Parameters+ Network.TLS.PostHandshake+ Network.TLS.RNG+ Network.TLS.Record+ Network.TLS.Record.Decrypt+ Network.TLS.Record.Encrypt+ Network.TLS.Record.Layer+ Network.TLS.Record.Recv+ Network.TLS.Record.Send+ Network.TLS.Record.State+ Network.TLS.Record.Types+ Network.TLS.Session+ 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.Wire+ Network.TLS.X509 -Benchmark bench-tls- Default-Language: Haskell2010- hs-source-dirs: Benchmarks Tests- Main-Is: Benchmarks.hs- type: exitcode-stdio-1.0- other-modules: Certificate- Connection- PipeChan- PubKey- Build-depends: base >= 4 && < 5- , tls- , x509- , x509-validation- , data-default-class- , cryptonite- , gauge- , bytestring- , asn1-types- , async >= 2.0- , hourglass- , QuickCheck >= 2- , tasty-quickcheck- , tls- ghc-options: -Wall -fno-warn-unused-imports+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ base16-bytestring,+ bytestring >=0.10 && <0.13,+ cereal >=0.5.3 && <0.6,+ crypton >=1.1.2 && <1.2,+ crypton-asn1-encoding >= 0.10.0 && < 0.11,+ crypton-asn1-types >= 0.4.1 && < 0.5,+ crypton-x509 >=1.9 && <1.10,+ crypton-x509-store >=1.9 && <1.10,+ crypton-x509-validation >=1.9 && <1.10,+ data-default,+ ech-config,+ hpke >=0.1.0 && <0.2,+ mlkem >= 0.2.0 && <0.3,+ mtl >=2.2 && <2.4,+ network >=3.1,+ ram >=0.22.0 && <0.23,+ random >=1.2 && <1.4,+ serialise >=0.2 && <0.3,+ transformers >=0.5 && <0.7,+ unix-time >=0.4.11 && <0.6,+ zlib >=0.7 && <0.8 -source-repository head- type: git- location: https://github.com/vincenthz/hs-tls- subdir: core+executable tls-server+ main-is: tls-server.hs+ hs-source-dirs: util+ other-modules:+ Common+ Server+ Imports++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall -threaded -rtsopts+ build-depends:+ base >=4.9 && <5,+ base16-bytestring,+ bytestring,+ containers,+ crypton,+ crypton-x509-store,+ crypton-x509-system,+ ech-config,+ network,+ network-run,+ tls++ if flag(devel)++ else+ buildable: False++executable tls-client+ main-is: tls-client.hs+ hs-source-dirs: util+ other-modules:+ Client+ Common+ Imports++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall -threaded -rtsopts+ build-depends:+ base >=4.9 && <5,+ base16-bytestring,+ bytestring,+ crypton,+ crypton-x509-store,+ crypton-x509-system,+ ech-config,+ network,+ network-run >=0.5,+ 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+ 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++benchmark tls-bench+ type: exitcode-stdio-1.0+ main-is: Benchmarks.hs+ hs-source-dirs: Benchmarks test+ other-modules:+ API+ Arbitrary+ Certificate+ CiphersSpec+ ECHSpec+ EncodeSpec+ HandshakeSpec+ PipeChan+ PubKey+ Run+ Session+ ThreadSpec++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ QuickCheck,+ async,+ base64-bytestring,+ bytestring,+ containers,+ crypton,+ crypton-asn1-types,+ crypton-x509,+ crypton-x509-store,+ crypton-x509-validation,+ data-default,+ ech-config,+ hspec,+ network,+ network-run,+ serialise,+ tasty-bench,+ time-hourglass,+ tls
+ util/Client.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Client (+ Aux (..),+ Cli,+ 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++import Imports++data Aux = Aux+ { auxAuthority :: HostName+ , auxPort :: ServiceName+ , auxDebugPrint :: String -> IO ()+ , auxShow :: ByteString -> IO ()+ , auxReadResumptionData :: IO [(SessionID, SessionData)]+ }++type Cli = Aux -> NonEmpty ByteString -> Context -> IO ()++clientHTTP11 :: Cli+clientHTTP11 aux@Aux{..} paths ctx = do+ sendData ctx $+ 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+ if bs == ""+ then auxShow "\n"+ else auxShow bs >> loop
+ util/Common.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}+-- Disable this warning so we can still test deprecated functionality.+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++module Common (+ printDHParams,+ printGroups,+ readNumber,+ readDHParams,+ readGroups,+ getCertificateStore,+ getLogger,+ namedGroups,+ getInfo,+ printHandshakeInfo,+ showBytesHex,+) where++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.FFDHE+import System.Exit+import System.X509++import Imports++namedDHParams :: [(String, DHParams)]+namedDHParams =+ [ ("ffdhe2048", ffdhe2048)+ , ("ffdhe3072", ffdhe3072)+ , ("ffdhe4096", ffdhe4096)+ , ("ffdhe6144", ffdhe6144)+ , ("ffdhe8192", ffdhe8192)+ ]++{- FOURMOLU_DISABLE -}+namedGroups :: [(String, Group)]+namedGroups =+ [ ("ffdhe2048", FFDHE2048)+ , ("ffdhe3072", FFDHE3072)+ , ("ffdhe4096", FFDHE4096)+ , ("ffdhe6144", FFDHE6144)+ , ("ffdhe8192", FFDHE8192)+ , ("p256", P256)+ , ("p384", P384)+ , ("p521", P521)+ , ("x25519", X25519)+ , ("x448", X448)+ , ("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++readDHParams :: String -> IO (Maybe DHParams)+readDHParams s =+ case lookup s namedDHParams of+ Nothing -> (Just . read) `fmap` readFile s+ mparams -> return mparams++readGroups :: String -> [Group]+readGroups s = fromMaybe [] $ traverse (`lookup` namedGroups) (split ',' s)++printDHParams :: IO ()+printDHParams = do+ putStrLn "DH Parameters"+ putStrLn "====================================="+ forM_ namedDHParams $ \(name, _) -> putStrLn name+ putStrLn "(or /path/to/dhparams)"++printGroups :: IO ()+printGroups = do+ putStrLn "Groups"+ putStrLn "====================================="+ forM_ namedGroups $ \(name, _) -> putStrLn name++split :: Char -> String -> [String]+split _ "" = []+split c s = case break (c ==) s of+ ("", _ : rs) -> split c rs+ (s', "") -> [s']+ (s', _ : rs) -> s' : split c rs++getCertificateStore :: [FilePath] -> IO CertificateStore+getCertificateStore [] = getSystemCertificateStore+getCertificateStore paths = foldM readPathAppend mempty paths+ where+ readPathAppend acc path = do+ mstore <- readCertificateStore path+ case mstore of+ Nothing -> error ("invalid certificate store: " ++ path)+ Just st -> return $! mappend st acc++getLogger :: Maybe FilePath -> (String -> IO ())+getLogger Nothing = \_ -> return ()+getLogger (Just file) = \msg -> appendFile file (msg ++ "\n")++getInfo :: Context -> IO Information+getInfo ctx = do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> do+ putStrLn "Error: information cannot be obtained"+ exitFailure+ Just info -> return info++printHandshakeInfo :: Information -> IO ()+printHandshakeInfo i = do+ putStrLn $ "Version: " ++ show (infoVersion i)+ putStrLn $ "Cipher: " ++ show (infoCipher i)+ putStrLn $ "Compression: " ++ show (infoCompression i)+ putStrLn $ "Groups: " ++ maybe "(none)" show (infoSupportedGroup i)+ when (infoVersion i < TLS13) $ do+ putStrLn $ "Extended master secret: " ++ show (infoExtendedMainSecret i)+ putStrLn $ "Resumption: " ++ show (infoTLS12Resumption i)+ 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/Imports.hs view
@@ -0,0 +1,17 @@+module Imports (+ ByteString,+ module Control.Applicative,+ module Control.Monad,+ module Data.List,+ module Data.Maybe,+ module Data.Monoid,+ module Data.Word,+) where++import Control.Applicative+import Control.Monad+import Data.ByteString (ByteString)+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Word
+ util/Server.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module Server where++import qualified Data.ByteString as BS+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++-- "<>" 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: "+ <> C8.pack (show (BS.length body))+ <> "\r\n"+ <> "\r\n"+ <> body+ where+ body = "<html><<body>Hello world!</body></html>"++server :: Context -> Bool -> IO ()+server ctx showRequest = do+ bs <- recvData ctx+ case C8.uncons bs of+ Nothing -> return ()+ Just ('A', _) -> do+ sendData ctx $ CL8.fromStrict bs+ echo ctx+ Just _ -> handleHTML ctx showRequest bs++echo :: Context -> IO ()+echo ctx = loop+ where+ 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"+ 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 -> 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 "\n" bs0 of+ (_, "") -> do+ bs1 <- recvData ctx+ writeIORef ref (bs0 <> bs1)+ getline ref+ (bs1, bs2) -> do+ writeIORef ref $ BS.drop 1 bs2+ return $ BS.dropWhileEnd (== 0x0d) bs1
+ util/tls-client.hs view
@@ -0,0 +1,465 @@+{-# 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.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 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 Client+import Common+import Imports++data Options = Options+ { optDebugLog :: Bool+ , optShow :: Bool+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: [Group]+ , optValidate :: Bool+ , optVerNego :: Bool+ , optResumption :: Bool+ , 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)++defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optShow = False+ , optKeyLogFile = Nothing+ , optGroups = supportedGroups defaultSupported+ , optValidate = False+ , optVerNego = False+ , optResumption = False+ , opt0RTT = False+ , optRetry = False+ , 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: tls-client [OPTION] addr port [path]"++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info"+ , Option+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ "specify groups"+ , Option+ ['e']+ ["validate"]+ (NoArg (\o -> o{optValidate = True}))+ "validate server's certificate"+ , Option+ ['R']+ ["resumption"]+ (NoArg (\o -> o{optResumption = True}))+ "try session resumption"+ , Option+ ['Z']+ ["0rtt"]+ (NoArg (\o -> o{opt0RTT = True}))+ "try sending early data"+ , Option+ ['S']+ ["hello-retry"]+ (NoArg (\o -> o{optRetry = True}))+ "try client hello retry"+ , Option+ ['2']+ ["tls12"]+ (NoArg (\o -> o{optVersions = [TLS12]}))+ "use TLS 1.2"+ , Option+ ['3']+ ["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)+ exitFailure++clientOpts :: [String] -> IO (Options, [String])+clientOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ args <- getArgs+ (opts@Options{..}, ips) <- clientOpts args+ (host, port, paths) <- case ips of+ [] -> showUsageAndExit usage+ _ : [] -> showUsageAndExit usage+ h : p : [] -> return (h, p, ["/"])+ h : p : ps -> return (h, p, C8.pack <$> NE.fromList ps)+ when (null optGroups) $ do+ putStrLn "Error: unsupported groups"+ exitFailure+ 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 ()+ aux =+ Aux+ { auxAuthority = host+ , auxPort = port+ , auxDebugPrint = debug+ , auxShow = showContent+ , auxReadResumptionData = readIORef ref+ }+ 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 -> 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+ msd' <- auxReadResumptionData+ return (i1, msd')+ if+ | optResumption ->+ if isResumptionPossible msd+ then do+ let cparams2 = modifyClientParams cparams msd False+ info2 <- runClient2 opts client cparams2 aux paths+ if infoVersion info1 == TLS12+ then do+ if infoTLS12Resumption info2+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ if infoTLS13HandshakeMode info2 == Just PreSharedKey+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ | opt0RTT ->+ if is0RTTPossible info1 msd+ then do+ let cparams2 = modifyClientParams cparams msd True+ info2 <- runClient2 opts client cparams2 aux paths+ if infoTLS13HandshakeMode info2 == Just RTT0+ then do+ putStrLn "Result: (Z) 0-RTT ... OK"+ exitSuccess+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ | optRetry ->+ if infoTLS13HandshakeMode info1 == Just HelloRetryRequest+ then do+ putStrLn "Result: (S) retry ... OK"+ exitSuccess+ else do+ putStrLn "Result: (S) retry ... NG"+ exitFailure+ | otherwise -> do+ putStrLn "Result: (H) handshake ... OK"+ when (optALPN == "http/1.1") $+ putStrLn "Result: (1) HTTP/1.1 transaction ... OK"+ exitSuccess++runClient2+ :: Options+ -> Cli+ -> ClientParams+ -> Aux+ -> NonEmpty ByteString+ -> IO Information+runClient2 opts@Options{..} client cparams aux@Aux{..} paths = do+ threadDelay 100000+ auxDebugPrint "<<<< next connection >>>>"+ auxDebugPrint "------------------------"+ runTLS opts cparams aux $ \ctx -> do+ if opt0RTT+ then do+ void $ client aux paths ctx+ i <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i+ return i+ else do+ i <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i+ void $ client aux paths ctx+ return i++runTLS+ :: Options+ -> ClientParams+ -> Aux+ -> (Context -> IO a)+ -> IO a+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 -> [(SessionID, SessionData)] -> Bool -> ClientParams+modifyClientParams cparams ts early =+ cparams+ { clientWantSessionResumeList = ts+ , clientUseEarlyData = early+ }++getClientParams+ :: Options+ -> HostName+ -> ServiceName+ -> SessionManager+ -> Maybe CertificateStore+ -> OnCertificateRequest+ -> ECHConfigList+ -> (String -> IO ())+ -> (String -> IO ())+ -> ClientParams+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 =+ defaultShared+ { sharedSessionManager = sm+ , sharedCAStore = fromMaybe mempty mstore+ , sharedValidationCache = validateCache+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 8192+ }+ , sharedECHConfigList = echConfList+ }+ supported =+ defaultSupported+ { supportedVersions = optVersions+ , supportedGroups = groups+ }+ hooks =+ defaultClientHooks+ { onSuggestALPN = return $ Just [C8.pack optALPN]+ , onCertificateRequest = onCertReq+ }+ validateCache+ | isJust mstore = sharedValidationCache defaultShared+ | otherwise =+ ValidationCache+ (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ())+ debug =+ defaultDebugParams+ { debugKeyLogger = getLogger optKeyLogFile+ , debugError = printError+ , debugTraceKey = traceKey+ }++smIORef :: IORef [(SessionID, SessionData)] -> SessionManager+smIORef ref =+ noSessionManager+ { sessionEstablish = \sid sdata ->+ modifyIORef' ref (\xs -> (sid, sdata) : xs)+ >> printTicket sid sdata+ >> return Nothing+ }++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"++isResumptionPossible :: [(SessionID, SessionData)] -> Bool+isResumptionPossible = not . null++is0RTTPossible :: Information -> [(SessionID, SessionData)] -> Bool+is0RTTPossible _ [] = False+is0RTTPossible info xs =+ infoVersion info == TLS13+ && any (\(_, sd) -> sessionMaxEarlyDataSize sd > 0) xs
+ util/tls-server.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++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.Internal+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit+import System.IO+import System.X509++import Common+import Imports+import Server++data Options = Options+ { optDebugLog :: Bool+ , optClientAuth :: Bool+ , optShow :: Bool+ , optKeyLogFile :: Maybe FilePath+ , optTrustedAnchor :: Maybe FilePath+ , optGroups :: [Group]+ , optCertFile :: FilePath+ , optKeyFile :: FilePath+ , optECHConfigFile :: Maybe FilePath+ , optECHKeyFile :: Maybe FilePath+ , optTraceKey :: Bool+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optClientAuth = False+ , optShow = False+ , optKeyLogFile = Nothing+ , optTrustedAnchor = Nothing+ , -- excluding FFDHE8192 for retry+ optGroups = FFDHE8192 `delete` supportedGroups defaultSupported+ , optCertFile = "servercert.pem"+ , optKeyFile = "serverkey.pem"+ , optECHConfigFile = Nothing+ , optECHKeyFile = Nothing+ , optTraceKey = False+ }++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}))+ "print debug info"+ , Option+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ "groups for key exchange"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["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"+ ]++usage :: String+usage = "Usage: tls-server [OPTION] addr port"++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++serverOpts :: [String] -> IO (Options, [String])+serverOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ (Options{..}, ips) <- serverOpts args+ (host, port) <- case ips of+ [h, p] -> return (h, p)+ _ -> showUsageAndExit "cannot recognize <addr> and <port>\n"+ when (null optGroups) $ 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+ optClientAuth+ mstore+ ech+ printError+ traceKey+ 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+ -> [Group]+ -> SessionManager+ -> (String -> IO ())+ -> Bool+ -> Maybe CertificateStore+ -> ([(Word8, ByteString)], ECHConfigList)+ -> (String -> IO ())+ -> (String -> IO ())+ -> ServerParams+getServerParams creds groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey =+ defaultParamsServer+ { serverSupported = supported+ , serverShared = shared+ , serverHooks = hooks+ , serverDebug = debug+ , serverEarlyDataSize = 2048+ , serverWantClientCert = clientAuth+ , serverECHKey = ekey+ }+ where+ shared =+ defaultShared+ { sharedCredentials = creds+ , sharedSessionManager = sm+ , sharedCAStore = case mstore of+ Just store -> store+ Nothing -> sharedCAStore defaultShared+ , sharedECHConfigList = ecnf+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 16384+ }+ }+ supported =+ defaultSupported+ { supportedGroups = groups+ }+ hooks =+ defaultServerHooks+ { onALPNClientSuggest = Just chooseALPN+ , onClientCertificate = case mstore of+ Nothing -> onClientCertificate defaultServerHooks+ Just _ ->+ validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+ }+ debug =+ defaultDebugParams+ { debugKeyLogger = keyLog+ , debugError = printError+ , debugTraceKey = traceKey+ }++chooseALPN :: [ByteString] -> IO ByteString+chooseALPN protos+ | "http/1.1" `elem` protos = return "http/1.1"+ | otherwise = return ""++newSessionManager :: IO SessionManager+newSessionManager = do+ ref <- newIORef M.empty+ return $+ noSessionManager+ { sessionResume = \key -> do+ M.lookup key <$> readIORef ref+ , sessionResumeOnlyOnce = \key -> do+ M.lookup key <$> readIORef ref+ , sessionEstablish = \key val -> do+ atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing)+ , sessionInvalidate = \key -> do+ atomicModifyIORef' ref $ \m -> (M.delete key m, ())+ , sessionUseTicket = False+ }