diff --git a/Benchmarks/Benchmarks.hs b/Benchmarks/Benchmarks.hs --- a/Benchmarks/Benchmarks.hs +++ b/Benchmarks/Benchmarks.hs @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,228 @@ +# 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. @@ -147,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` diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -1,198 +1,363 @@ -{-# LANGUAGE CPP #-} -- | --- Module : Network.TLS --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 +-- > 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 @@ -202,9 +367,11 @@ getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain -{- $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. --} +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. diff --git a/Network/TLS/Backend.hs b/Network/TLS/Backend.hs --- a/Network/TLS/Backend.hs +++ b/Network/TLS/Backend.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Network.TLS.Backend --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 + } diff --git a/Network/TLS/Cap.hs b/Network/TLS/Cap.hs deleted file mode 100644 --- a/Network/TLS/Cap.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | --- Module : Network.TLS.Cap --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -1,146 +1,84 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} --- | --- Module : Network.TLS.Cipher --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs --- a/Network/TLS/Compression.hs +++ b/Network/TLS/Compression.hs @@ -1,40 +1,35 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} --- | --- Module : Network.TLS.Compression --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -1,113 +1,127 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Network.TLS.Context --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -1,78 +1,102 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} --- | --- Module : Network.TLS.Context.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) @@ -241,33 +374,33 @@ 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 -> liftIO $ throwIO $ MissingHandshake - 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 diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 --- 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 +-- > handshake ctx +-- > ... +-- > bye +-- +-- The following code ensures nothing but is no harm. +-- +-- > bracket (contextNew ) 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,221 +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" 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, 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) = 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" 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" 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 diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -1,34 +1,29 @@ --- | --- Module : Network.TLS.Credentials --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -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 diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs --- a/Network/TLS/Crypto/DH.hs +++ b/Network/TLS/Crypto/DH.hs @@ -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 diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs --- a/Network/TLS/Crypto/IES.hs +++ b/Network/TLS/Crypto/IES.hs @@ -1,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 -- 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 diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -1,23 +1,143 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} + -- | -- Module : Network.TLS.Crypto.Types -- License : BSD-style -- Maintainer : Kazu Yamamoto -- 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) diff --git a/Network/TLS/ErrT.hs b/Network/TLS/ErrT.hs --- a/Network/TLS/ErrT.hs +++ b/Network/TLS/ErrT.hs @@ -1,19 +1,13 @@ --- | --- Module : Network.TLS.ErrT --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Error.hs b/Network/TLS/Error.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Error.hs @@ -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 -} diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -1,701 +1,1175 @@ -{-# LANGUAGE BangPatterns #-} --- | --- Module : Network.TLS.Extension --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 -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. +-- +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" diff --git a/Network/TLS/Extension.hs-boot b/Network/TLS/Extension.hs-boot new file mode 100644 --- /dev/null +++ b/Network/TLS/Extension.hs-boot @@ -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} diff --git a/Network/TLS/Extra.hs b/Network/TLS/Extra.hs --- a/Network/TLS/Extra.hs +++ b/Network/TLS/Extra.hs @@ -1,15 +1,8 @@ --- | --- Module : Network.TLS.Extra --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -1,1156 +1,808 @@ --- | --- Module : Network.TLS.Extra.Cipher --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 crypton implementation. -sortOptimized :: [CipherSet] -> [Cipher] -sortOptimized = concatMap f - where - f (SetAead gcm chacha ccm) - | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm - | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm - | otherwise = gcm ++ ccm ++ chacha - f (SetOther ciphers) = ciphers - --- Order which is deterministic but not optimized for the CPU. -sortDeterministic :: [CipherSet] -> [Cipher] -sortDeterministic = concatMap f - where - f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm - f (SetOther ciphers) = ciphers - --- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to --- weak. This choice of ciphersuites should satisfy most normal needs. For --- otherwise strong ciphers we make little distinction between AES128 and --- 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} diff --git a/Network/TLS/Extra/CipherCBC.hs b/Network/TLS/Extra/CipherCBC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extra/CipherCBC.hs @@ -0,0 +1,201 @@ +module Network.TLS.Extra.CipherCBC ( + -- * TLS 1.2 CBC ciphers with PFS and SHA2 + ciphersuite_pfs_sha2_cbc, + ciphersuite_ecdhe_sha2_cbc, + ciphersuite_dhe_rsa_sha2_cbc, + + -- ** Individual CBC ciphers + cipher_DHE_RSA_AES128_SHA256, + cipher_DHE_RSA_AES256_SHA256, + cipher_ECDHE_RSA_AES128CBC_SHA256, + cipher_ECDHE_RSA_AES256CBC_SHA384, + cipher_ECDHE_ECDSA_AES128CBC_SHA256, +) where + +import Crypto.Cipher.AES +import Crypto.Cipher.Types hiding (Cipher, cipherName) +import Crypto.Error +-- import Crypto.System.CPU +import qualified Data.ByteString as B + +import Network.TLS.Cipher +import Network.TLS.Imports +import Network.TLS.Types hiding (IV) + +---------------------------------------------------------------- + +-- | TLS 1.2 AES CBC ciphers with DHE or ECDHE key exchange, ECDSA or RSA +-- authentication and a SHA256 or SHA2384 MAC. +-- For legacy applications only, deprecated in HTTPS. +ciphersuite_pfs_sha2_cbc :: [Cipher] +ciphersuite_pfs_sha2_cbc = + [ cipher_ECDHE_ECDSA_AES128CBC_SHA256 + , cipher_ECDHE_ECDSA_AES256CBC_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA256 + , cipher_ECDHE_RSA_AES256CBC_SHA384 + , cipher_DHE_RSA_AES128_SHA256 + , cipher_DHE_RSA_AES256_SHA256 + ] + +-- | TLS 1.2 AES CBC ciphers with ECDHE key exchange, ECDSA or RSA +-- authentication and a SHA256 or SHA2384 MAC. +-- For legacy applications only, deprecated in HTTPS. +ciphersuite_ecdhe_sha2_cbc :: [Cipher] +ciphersuite_ecdhe_sha2_cbc = + [ cipher_ECDHE_ECDSA_AES128CBC_SHA256 + , cipher_ECDHE_ECDSA_AES256CBC_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA256 + , cipher_ECDHE_RSA_AES256CBC_SHA384 + ] + +-- | TLS 1.2 AES CBC ciphers with DHE key exchange, RSA authentication and a +-- SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +ciphersuite_dhe_rsa_sha2_cbc :: [Cipher] +ciphersuite_dhe_rsa_sha2_cbc = + [ cipher_DHE_RSA_AES256_SHA256 + , cipher_DHE_RSA_AES128_SHA256 + ] + +---------------------------------------------------------------- + +-- | TLS 1.2 AES128 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_DHE_RSA_AES128_SHA256 :: Cipher +cipher_DHE_RSA_AES128_SHA256 = + Cipher + { cipherID = 0x0067 + , cipherName = "DHE-RSA-AES128-SHA256" + , cipherBulk = bulk_aes128 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +-- | TLS 1.2 AES256 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_DHE_RSA_AES256_SHA256 :: Cipher +cipher_DHE_RSA_AES256_SHA256 = + cipher_DHE_RSA_AES128_SHA256 + { cipherID = 0x006B + , cipherName = "DHE-RSA-AES256-SHA256" + , cipherBulk = bulk_aes256 + } + +-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, RSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher +cipher_ECDHE_RSA_AES128CBC_SHA256 = + Cipher + { cipherID = 0xC027 + , cipherName = "ECDHE-RSA-AES128CBC-SHA256" + , cipherBulk = bulk_aes128 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, RSA authentication and a SHA384 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher +cipher_ECDHE_RSA_AES256CBC_SHA384 = + Cipher + { cipherID = 0xC028 + , cipherName = "ECDHE-RSA-AES256CBC-SHA384" + , cipherBulk = bulk_aes256 + , cipherHash = SHA384 + , cipherPRFHash = Just SHA384 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, ECDSA authentication and a SHA256 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128CBC_SHA256 = + Cipher + { cipherID = 0xc023 + , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256" + , cipherBulk = bulk_aes128 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, ECDSA authentication and a SHA384 MAC. +-- For legacy applications only, deprecated in HTTPS. +cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher +cipher_ECDHE_ECDSA_AES256CBC_SHA384 = + Cipher + { cipherID = 0xC024 + , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384" + , cipherBulk = bulk_aes256 + , cipherHash = SHA384 + , cipherPRFHash = Just SHA384 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +---------------------------------------------------------------- + +aes128cbc :: BulkDirection -> BulkKey -> BulkBlock +aes128cbc BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \iv input -> + let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output) + ) +aes128cbc BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \iv input -> + let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input) + ) + +aes256cbc :: BulkDirection -> BulkKey -> BulkBlock +aes256cbc BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \iv input -> + let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output) + ) +aes256cbc BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \iv input -> + let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input) + ) + +makeIV_ :: BlockCipher a => B.ByteString -> IV a +makeIV_ = fromMaybe (error "makeIV_") . makeIV + +takelast :: Int -> B.ByteString -> B.ByteString +takelast i b = B.drop (B.length b - i) b + +noFail :: CryptoFailable a -> a +noFail = throwCryptoError + +---------------------------------------------------------------- + +bulk_aes128 :: Bulk +bulk_aes128 = + Bulk + { bulkName = "AES128" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes128cbc + } + +bulk_aes256 :: Bulk +bulk_aes256 = + Bulk + { bulkName = "AES256" + , bulkKeySize = 32 + , bulkIVSize = 16 + , bulkExplicitIV = 0 + , bulkAuthTagLen = 0 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes256cbc + } diff --git a/Network/TLS/Extra/FFDHE.hs b/Network/TLS/Extra/FFDHE.hs --- a/Network/TLS/Extra/FFDHE.hs +++ b/Network/TLS/Extra/FFDHE.hs @@ -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 + } diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -1,38 +1,33 @@ --- | --- Module : Network.TLS.Handshake --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -1,25 +1,26 @@ --- | --- Module : Network.TLS.Handshake.Certificate --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 @@ -41,16 +42,30 @@ 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 diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -1,1072 +1,177 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.Client --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" 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" 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" IllegalParameter - groups' -> do - when (isJust mparams) $ - throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage - mks <- usingState_ ctx getTLS13KeyShare - case mks of - Just (KeyShareHRR selectedGroup) - | selectedGroup `elem` groups' -> do - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest - 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" IllegalParameter - Just _ -> error "handshakeClient': invalid KeyShare value" - Nothing -> throwCore $ Error_Protocol "key exchange not implemented in HRR, expected key_share extension" HandshakeFailure - else - handshakeClient13 cparams ctx groupToSend - else do - when rtt0 $ - throwCore $ Error_Protocol "server denied TLS 1.3 when connecting with early data" 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) 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") InternalError - ver <- usingState_ ctx getVersion - unless (pubkey `versionCompatible` ver) $ - throwCore $ Error_Protocol (pubkeyType pubkey ++ " credential is not supported at version " ++ show ver) 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) 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" 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" 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, 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") 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") 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" 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" ProtocolVersion - when (rver == SSL3) $ throwCore $ Error_Protocol "SSL3 is not supported" 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" IllegalParameter - Just alg -> return alg - compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of - Nothing -> throwCore $ Error_Protocol "server choose unknown compression" 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" 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" IllegalParameter - - case find (== ver) (supportedVersions $ ctxSupported ctx) of - Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported") ProtocolVersion - Just _ -> return () - if ver > TLS12 then do - when (serverSession /= clientSession) $ - throwCore $ Error_Protocol "received mismatched legacy session" 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" 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 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" 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) 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 - -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" 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" IllegalParameter - Nothing -> throwCore $ Error_Protocol "key exchange not implemented, expected key_share extension" HandshakeFailure - let grp = keyShareEntryGroup serverKeyShare - unless (checkKeyShareKeyLength serverKeyShare) $ - throwCore $ Error_Protocol "broken key_share" IllegalParameter - unless (groupSent == Just grp) $ - throwCore $ Error_Protocol "received incompatible group for (EC)DHE" 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" IllegalParameter - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - return (earlySecretPSK, True) - Just _ -> throwCore $ Error_Protocol "selected identity out of range" 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" 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" 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 - {- 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" 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" UnexpectedMessage - sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN) - -postHandshakeAuthClientWith _ _ _ = - throwCore $ Error_Protocol "unexpected handshake message received in postHandshakeAuthClientWith" 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 diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -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 diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/Common.hs @@ -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] diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -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') diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -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] [] diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -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 diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -1,256 +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 + 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) + 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 _ ad) = (AlertLevel_Fatal, ad) -errorToAlert (Error_Protocol_Warning _ ad) = (AlertLevel_Warning, 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_unexpected msg _) = msg +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" 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 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" 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 @@ -262,3 +285,158 @@ 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 diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -1,71 +1,76 @@ -{-# 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 --- 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.UnixTime -import Foreign.C.Types (CTime(..)) +import Foreign.C.Types (CTime (..)) import Network.TLS.Cipher -import Network.TLS.Compression 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.Common (unexpected) import Network.TLS.Handshake.Key -import Network.TLS.Handshake.Process (processHandshake13) import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State -import Network.TLS.Handshake.State13 +import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO +import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC +import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct @@ -73,63 +78,71 @@ import Network.TLS.Types import Network.TLS.Wire -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" 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) IllegalParameter - Right cpub -> do - ecdhePair <- generateECDHEShared ctx cpub - case ecdhePair of - Nothing -> throwCore $ Error_Protocol msgInvalidPublic 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) IllegalParameter - Right spub -> case IES.groupGetShared spub cpri of - Just shared -> return $ BA.convert shared - Nothing -> throwCore $ Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter +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,43 +281,50 @@ 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 @@ -309,80 +337,92 @@ fromIntegral ((s - base) * 1000) + fromIntegral (us `div` 1000) where base = 1483228800 - -- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT" +-- 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" 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 @@ -401,47 +441,38 @@ 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 diff --git a/Network/TLS/Handshake/Control.hs b/Network/TLS/Handshake/Control.hs --- a/Network/TLS/Handshake/Control.hs +++ b/Network/TLS/Handshake/Control.hs @@ -1,18 +1,11 @@ --- | --- Module : Network.TLS.Handshake.Control --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -1,54 +1,48 @@ {-# LANGUAGE FlexibleInstances #-} --- | --- Module : Network.TLS.Handshake.Key --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" 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) 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 diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs deleted file mode 100644 --- a/Network/TLS/Handshake/Process.hs +++ /dev/null @@ -1,146 +0,0 @@ --- | --- Module : Network.TLS.Handshake.Process --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) HandshakeFailure - - setSecureRenegotiation True - -- unknown extensions - processClientExtension _ = return () - - processCertificates :: Role -> CertificateChain -> IO () - processCertificates ServerRole (CertificateChain []) = return () - processCertificates ClientRole (CertificateChain []) = - throwCore $ Error_Protocol "server certificate missing" 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" 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" 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" 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 diff --git a/Network/TLS/Handshake/Random.hs b/Network/TLS/Handshake/Random.hs --- a/Network/TLS/Handshake/Random.hs +++ b/Network/TLS/Handshake/Random.hs @@ -1,21 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} --- | --- Module : Network.TLS.Handshake.Random --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -1,1214 +1,89 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.Server --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" 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 - - -- Handle Client hello - processHandshake ctx clientHello - - -- rejecting SSL2. RFC 6176 - when (legacyVersion == SSL2) $ throwCore $ Error_Protocol "SSL 2.0 is not supported" ProtocolVersion - -- rejecting SSL3. RFC 7568 - when (legacyVersion == SSL3) $ throwCore $ Error_Protocol "SSL 3.0 is not supported" 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" 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") 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 - - -- 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" 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" 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" 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" 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 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" 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" 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 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" 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" 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" 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" 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" IllegalParameter - return $ Just k - _ -> throwCore $ Error_Protocol "duplicated key_share" 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" 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" MissingExtension - Just sa -> case extensionDecode MsgTClientHello sa of - Nothing -> throwCore $ Error_Protocol "broken signature_algorithms extension" 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" 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" 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" 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" 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" 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" 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" 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" 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" 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 diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ClientHello12.hs b/Network/TLS/Handshake/Server/ClientHello12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ClientHello12.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/Common.hs b/Network/TLS/Handshake/Server/Common.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/Common.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -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 + } diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -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.. 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 diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -1,43 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.Signature --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 DecryptError @@ -45,26 +39,26 @@ -- 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 IllegalParameter diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -1,519 +1,569 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.State --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 - 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 +-- 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 diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -1,67 +1,72 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.State13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" 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 diff --git a/Network/TLS/Handshake/TranscriptHash.hs b/Network/TLS/Handshake/TranscriptHash.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/TranscriptHash.hs @@ -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 ++ " ") diff --git a/Network/TLS/HashAndSignature.hs b/Network/TLS/HashAndSignature.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/HashAndSignature.hs @@ -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 -} diff --git a/Network/TLS/Hooks.hs b/Network/TLS/Hooks.hs --- a/Network/TLS/Hooks.hs +++ b/Network/TLS/Hooks.hs @@ -1,21 +1,16 @@ --- | --- Module : Network.TLS.Context --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -1,25 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} --- | --- Module : Network.TLS.IO --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 @@ -29,11 +24,11 @@ import Network.TLS.Context.Internal import Network.TLS.Hooks +import Network.TLS.IO.Decode +import Network.TLS.IO.Encode import Network.TLS.Imports -import Network.TLS.Receiving +import Network.TLS.Parameters import Network.TLS.Record -import Network.TLS.Record.Layer -import Network.TLS.Sending import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 @@ -41,130 +36,169 @@ ---------------------------------------------------------------- -- | 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 _ 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 @@ -182,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 :)) diff --git a/Network/TLS/IO/Decode.hs b/Network/TLS/IO/Decode.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/IO/Decode.hs @@ -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") diff --git a/Network/TLS/IO/Encode.hs b/Network/TLS/IO/Encode.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/IO/Encode.hs @@ -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 diff --git a/Network/TLS/Imports.hs b/Network/TLS/Imports.hs --- a/Network/TLS/Imports.hs +++ b/Network/TLS/Imports.hs @@ -1,60 +1,34 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} --- | --- Module : Network.TLS.Imports --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) - diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -1,28 +1,37 @@ {-# OPTIONS_HADDOCK hide #-} --- | --- Module : Network.TLS.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/KeySchedule.hs b/Network/TLS/KeySchedule.hs --- a/Network/TLS/KeySchedule.hs +++ b/Network/TLS/KeySchedule.hs @@ -1,40 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.KeySchedule --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -1,81 +1,83 @@ --- | --- Module : Network.TLS.MAC --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Measurement.hs b/Network/TLS/Measurement.hs --- a/Network/TLS/Measurement.hs +++ b/Network/TLS/Measurement.hs @@ -1,46 +1,44 @@ --- | --- Module : Network.TLS.Measurement --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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} diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -1,309 +1,297 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Packet --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -1,163 +1,176 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --- | --- Module : Network.TLS.Packet13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -1,636 +1,899 @@ --- | --- Module : Network.TLS.Parameters --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 - -- - -- 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 - -- - -- 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 - -- - -- 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 + -- 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 + -- 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 + -- + -- 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 + } diff --git a/Network/TLS/PostHandshake.hs b/Network/TLS/PostHandshake.hs --- a/Network/TLS/PostHandshake.hs +++ b/Network/TLS/PostHandshake.hs @@ -1,39 +1,33 @@ --- | --- Module : Network.TLS.PostHandshake --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -1,12 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} + -- | --- Module : Network.TLS.QUIC --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" 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" 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,7 +230,9 @@ 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. @@ -239,23 +244,21 @@ 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 diff --git a/Network/TLS/RNG.hs b/Network/TLS/RNG.hs --- a/Network/TLS/RNG.hs +++ b/Network/TLS/RNG.hs @@ -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 diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs deleted file mode 100644 --- a/Network/TLS/Receiving.hs +++ /dev/null @@ -1,102 +0,0 @@ --- | --- Module : Network.TLS.Receiving --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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") diff --git a/Network/TLS/Record.hs b/Network/TLS/Record.hs --- a/Network/TLS/Record.hs +++ b/Network/TLS/Record.hs @@ -1,42 +1,36 @@ --- | --- Module : Network.TLS.Record --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Record/Decrypt.hs b/Network/TLS/Record/Decrypt.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Decrypt.hs @@ -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) diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs deleted file mode 100644 --- a/Network/TLS/Record/Disengage.hs +++ /dev/null @@ -1,201 +0,0 @@ --- | --- Module : Network.TLS.Record.Disengage --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 UnexpectedMessage - Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d) - ProtocolType_ChangeCipherSpec -> noDecryption - ProtocolType_Alert -> noDecryption - _ -> throwError $ Error_Protocol "illegal plain text" UnexpectedMessage - -unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString) -unInnerPlaintext inner = - case B.unsnoc dc of - Nothing -> Left $ unknownContentType13 (0 :: Word8) - Just (bytes,c) -> - 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" 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" 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) diff --git a/Network/TLS/Record/Encrypt.hs b/Network/TLS/Record/Encrypt.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Encrypt.hs @@ -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 diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs deleted file mode 100644 --- a/Network/TLS/Record/Engage.hs +++ /dev/null @@ -1,146 +0,0 @@ --- | --- Module : Network.TLS.Record.Engage --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Record/Layer.hs b/Network/TLS/Record/Layer.hs --- a/Network/TLS/Record/Layer.hs +++ b/Network/TLS/Record/Layer.hs @@ -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 diff --git a/Network/TLS/Record/Reading.hs b/Network/TLS/Record/Reading.hs deleted file mode 100644 --- a/Network/TLS/Record/Reading.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Network.TLS.Record.Reading --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" 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" 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)) diff --git a/Network/TLS/Record/Recv.hs b/Network/TLS/Record/Recv.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Recv.hs @@ -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) + ) diff --git a/Network/TLS/Record/Send.hs b/Network/TLS/Record/Send.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Send.hs @@ -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 diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -1,106 +1,111 @@ {-# LANGUAGE MultiParamTypeClasses #-} --- | --- Module : Network.TLS.Record.State --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs --- a/Network/TLS/Record/Types.hs +++ b/Network/TLS/Record/Types.hs @@ -1,88 +1,78 @@ {-# LANGUAGE EmptyDataDecls #-} --- | --- Module : Network.TLS.Record.Types --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Record/Writing.hs b/Network/TLS/Record/Writing.hs deleted file mode 100644 --- a/Network/TLS/Record/Writing.hs +++ /dev/null @@ -1,69 +0,0 @@ --- | --- Module : Network.TLS.Record.Writing --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs deleted file mode 100644 --- a/Network/TLS/Sending.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | --- Module : Network.TLS.Sending --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs --- a/Network/TLS/Session.hs +++ b/Network/TLS/Session.hs @@ -1,34 +1,35 @@ --- | --- Module : Network.TLS.Session --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 + } diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -1,253 +1,325 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | --- Module : Network.TLS.State --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -1,81 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | --- Module : Network.TLS.Struct --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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,610 +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. --- --- 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 = - Error_Misc String -- ^ mainly for instance of Error - | Error_Protocol String AlertDescription - -- ^ A fatal error condition was encountered at a low level. The - -- elements of the tuple give (freeform text description, structured - -- error description). - | Error_Protocol_Warning 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_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 --- | 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 = - Terminated Bool String TLSError - -- ^ Early termination exception with the reason and the error associated - | HandshakeFailed TLSError - -- ^ Handshake failed for the reason attached. - | PostHandshake TLSError - -- ^ Failure occurred while sending or receiving data after the - -- TLS handshake succeeded. - | Uncontextualized TLSError - -- ^ Lifts a 'TLSError' into 'TLSException' without provided any context - -- around when the error happened. - | ConnectionNotEstablished - -- ^ 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. - | MissingHandshake - -- ^ Expected that a TLS handshake had already taken place, but no TLS - -- handshake had occurred. - -- Indicates that this library has been used incorrectly. - deriving (Show,Eq,Typeable) +pattern ProtocolType_AppData :: ProtocolType +pattern ProtocolType_AppData = ProtocolType 23 -instance Exception TLSException +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 -} -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) diff --git a/Network/TLS/Struct13.hs b/Network/TLS/Struct13.hs --- a/Network/TLS/Struct13.hs +++ b/Network/TLS/Struct13.hs @@ -1,102 +1,81 @@ --- | --- Module : Network.TLS.Struct13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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) diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -1,144 +1,71 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} --- | --- Module : Network.TLS.Types --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 +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 -#ifdef INCLUDE_NETWORK import Network.Socket (HostName) -#endif import Network.TLS.Imports -import Network.TLS.Crypto.Types (Group) - -#ifndef INCLUDE_NETWORK -type HostName = String -#endif -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 - -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) - --- | Cipher identification -type CipherID = Word16 +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] diff --git a/Network/TLS/Types/Cipher.hs b/Network/TLS/Types/Cipher.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Cipher.hs @@ -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) diff --git a/Network/TLS/Types/Secret.hs b/Network/TLS/Types/Secret.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Secret.hs @@ -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 diff --git a/Network/TLS/Types/Session.hs b/Network/TLS/Types/Session.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Session.hs @@ -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 diff --git a/Network/TLS/Types/Version.hs b/Network/TLS/Types/Version.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Version.hs @@ -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 diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -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. diff --git a/Network/TLS/Util/ASN1.hs b/Network/TLS/Util/ASN1.hs --- a/Network/TLS/Util/ASN1.hs +++ b/Network/TLS/Util/ASN1.hs @@ -1,37 +1,32 @@ --- | --- Module : Network.TLS.Util.ASN1 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 [] diff --git a/Network/TLS/Util/Serialization.hs b/Network/TLS/Util/Serialization.hs --- a/Network/TLS/Util/Serialization.hs +++ b/Network/TLS/Util/Serialization.hs @@ -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) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -1,87 +1,84 @@ --- | --- Module : Network.TLS.Wire --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Network/TLS/X509.hs b/Network/TLS/X509.hs --- a/Network/TLS/X509.hs +++ b/Network/TLS/X509.hs @@ -1,66 +1,82 @@ --- | --- Module : Network.TLS.X509 --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs deleted file mode 100644 --- a/Tests/Certificate.hs +++ /dev/null @@ -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) diff --git a/Tests/Ciphers.hs b/Tests/Ciphers.hs deleted file mode 100644 --- a/Tests/Ciphers.hs +++ /dev/null @@ -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 diff --git a/Tests/Connection.hs b/Tests/Connection.hs deleted file mode 100644 --- a/Tests/Connection.hs +++ /dev/null @@ -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" diff --git a/Tests/Marshalling.hs b/Tests/Marshalling.hs deleted file mode 100644 --- a/Tests/Marshalling.hs +++ /dev/null @@ -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 diff --git a/Tests/PipeChan.hs b/Tests/PipeChan.hs deleted file mode 100644 --- a/Tests/PipeChan.hs +++ /dev/null @@ -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) diff --git a/Tests/PubKey.hs b/Tests/PubKey.hs deleted file mode 100644 --- a/Tests/PubKey.hs +++ /dev/null @@ -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) diff --git a/Tests/Tests.hs b/Tests/Tests.hs deleted file mode 100644 --- a/Tests/Tests.hs +++ /dev/null @@ -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) diff --git a/test/API.hs b/test/API.hs new file mode 100644 --- /dev/null +++ b/test/API.hs @@ -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 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Arbitrary.hs @@ -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 diff --git a/test/Certificate.hs b/test/Certificate.hs new file mode 100644 --- /dev/null +++ b/test/Certificate.hs @@ -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" diff --git a/test/CiphersSpec.hs b/test/CiphersSpec.hs new file mode 100644 --- /dev/null +++ b/test/CiphersSpec.hs @@ -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 diff --git a/test/ECHSpec.hs b/test/ECHSpec.hs new file mode 100644 --- /dev/null +++ b/test/ECHSpec.hs @@ -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" diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/EncodeSpec.hs @@ -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 diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HandshakeSpec.hs @@ -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 () diff --git a/test/PipeChan.hs b/test/PipeChan.hs new file mode 100644 --- /dev/null +++ b/test/PipeChan.hs @@ -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) diff --git a/test/PubKey.hs b/test/PubKey.hs new file mode 100644 --- /dev/null +++ b/test/PubKey.hs @@ -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" diff --git a/test/Run.hs b/test/Run.hs new file mode 100644 --- /dev/null +++ b/test/Run.hs @@ -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" diff --git a/test/Session.hs b/test/Session.hs new file mode 100644 --- /dev/null +++ b/test/Session.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/ThreadSpec.hs b/test/ThreadSpec.hs new file mode 100644 --- /dev/null +++ b/test/ThreadSpec.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,48 +1,29 @@ cabal-version: >=1.10 name: tls -version: 1.9.0 +version: 2.4.3 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez maintainer: Kazu Yamamoto author: Vincent Hanquez -stability: experimental homepage: https://github.com/haskell-tls/hs-tls -synopsis: TLS/SSL protocol native implementation (Server and Client) +synopsis: TLS protocol native implementation 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 - . + Native Haskell TLS 1.2/1.3 protocol implementation for servers and clients. category: Network build-type: Simple extra-source-files: - Tests/*.hs + test/*.hs CHANGELOG.md source-repository head type: git location: https://github.com/haskell-tls/hs-tls - subdir: core - -flag compat - description: - Accept SSLv2 client hello for beginning SSLv3 / TLS handshake - -flag network - description: Use the base network library + subdir: tls -flag hans - description: Use the Haskell Network Stack (HaNS) +flag devel + description: Development commands default: False library @@ -53,11 +34,11 @@ Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher + Network.TLS.Extra.CipherCBC Network.TLS.Extra.FFDHE Network.TLS.QUIC other-modules: - Network.TLS.Cap Network.TLS.Struct Network.TLS.Struct13 Network.TLS.Core @@ -70,22 +51,39 @@ 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.Process 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 @@ -94,109 +92,189 @@ Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.PostHandshake + Network.TLS.RNG Network.TLS.Record - Network.TLS.Record.Disengage - Network.TLS.Record.Engage + Network.TLS.Record.Decrypt + Network.TLS.Record.Encrypt Network.TLS.Record.Layer - Network.TLS.Record.Reading - Network.TLS.Record.Writing + Network.TLS.Record.Recv + Network.TLS.Record.Send Network.TLS.Record.State Network.TLS.Record.Types - Network.TLS.RNG - Network.TLS.State Network.TLS.Session - Network.TLS.Sending - Network.TLS.Receiving + Network.TLS.State + Network.TLS.Types + Network.TLS.Types.Cipher + Network.TLS.Types.Secret + Network.TLS.Types.Session + Network.TLS.Types.Version Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization - Network.TLS.Types Network.TLS.Wire Network.TLS.X509 - default-language: Haskell2010 - ghc-options: -Wall + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall build-depends: base >=4.9 && <5, - mtl >=2.2.1, - transformers, - cereal >=0.5.3, + 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 + +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, - data-default-class, - memory >=0.14.6, + containers, crypton, - asn1-types >=0.2.0, - asn1-encoding, - crypton-x509 >=1.7.5, - crypton-x509-store >=1.6, - crypton-x509-validation >=1.6.5, - async >=2.0, - unix-time + crypton-x509-store, + crypton-x509-system, + ech-config, + network, + network-run, + tls - if flag(network) - cpp-options: -DINCLUDE_NETWORK - build-depends: network >=2.4.0.0 + if flag(devel) - if flag(hans) - cpp-options: -DINCLUDE_HANS - build-depends: hans + else + buildable: False - if flag(compat) - cpp-options: -DSSLV2_COMPATIBLE +executable tls-client + main-is: tls-client.hs + hs-source-dirs: util + other-modules: + Client + Common + Imports -test-suite test-tls - type: exitcode-stdio-1.0 - main-is: Tests.hs - hs-source-dirs: Tests + 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 - Ciphers - Connection - Marshalling + CiphersSpec + ECHSpec + EncodeSpec + HandshakeSpec PipeChan PubKey + Run + Session + ThreadSpec - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-imports + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall -threaded -rtsopts build-depends: - base >=3 && <5, - async >=2.0, - data-default-class, - tasty, - tasty-quickcheck, - tls, + base >=4.9 && <5, QuickCheck, - crypton, + async, + base64-bytestring, bytestring, - asn1-types, + crypton, + crypton-asn1-types, crypton-x509, crypton-x509-validation, - hourglass + ech-config, + hspec, + ram, + serialise, + time-hourglass, + tls -benchmark bench-tls +benchmark tls-bench type: exitcode-stdio-1.0 main-is: Benchmarks.hs - hs-source-dirs: Benchmarks Tests + hs-source-dirs: Benchmarks test other-modules: + API + Arbitrary Certificate - Connection + CiphersSpec + ECHSpec + EncodeSpec + HandshakeSpec PipeChan PubKey + Run + Session + ThreadSpec default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-imports + ghc-options: -Wall build-depends: - base >=4 && <5, - tls, + base >=4.9 && <5, + QuickCheck, + async, + base64-bytestring, + bytestring, + containers, + crypton, + crypton-asn1-types, crypton-x509, + crypton-x509-store, crypton-x509-validation, - data-default-class, - crypton, - gauge, - bytestring, - asn1-types, - async >=2.0, - hourglass, - QuickCheck >=2, - tasty-quickcheck, + data-default, + ech-config, + hspec, + network, + network-run, + serialise, + tasty-bench, + time-hourglass, tls diff --git a/util/Client.hs b/util/Client.hs new file mode 100644 --- /dev/null +++ b/util/Client.hs @@ -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 diff --git a/util/Common.hs b/util/Common.hs new file mode 100644 --- /dev/null +++ b/util/Common.hs @@ -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 diff --git a/util/Imports.hs b/util/Imports.hs new file mode 100644 --- /dev/null +++ b/util/Imports.hs @@ -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 diff --git a/util/Server.hs b/util/Server.hs new file mode 100644 --- /dev/null +++ b/util/Server.hs @@ -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 = "<Hello world!" + +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 diff --git a/util/tls-client.hs b/util/tls-client.hs new file mode 100644 --- /dev/null +++ b/util/tls-client.hs @@ -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}) "") + "a file to store negotiated secrets" + , Option + ['g'] + ["groups"] + (ReqArg (\gs o -> o{optGroups = readGroups gs}) "") + "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}) "") + "set ALPN" + , Option + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = Just fl}) "") + "certificate file" + , Option + ['k'] + ["key"] + (ReqArg (\fl o -> o{optKeyFile = Just fl}) "") + "key file" + , Option + [] + ["ech-config"] + (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "") + "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}) "") + "trusted anchor file" + ] + +showUsageAndExit :: String -> IO a +showUsageAndExit msg = do + putStrLn msg + putStrLn $ usageInfo usage options + putStrLn $ " = " ++ 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 diff --git a/util/tls-server.hs b/util/tls-server.hs new file mode 100644 --- /dev/null +++ b/util/tls-server.hs @@ -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}) "") + "a file to store negotiated secrets" + , Option + ['g'] + ["groups"] + (ReqArg (\gs o -> o{optGroups = readGroups gs}) "") + "groups for key exchange" + , Option + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = fl}) "") + "certificate file" + , Option + ['k'] + ["key"] + (ReqArg (\fl o -> o{optKeyFile = fl}) "") + "key file" + , Option + ['t'] + ["trusted-anchor"] + (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "") + "trusted anchor file" + , Option + [] + ["ech-config"] + (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "") + "ECH config file" + , Option + [] + ["ech-key"] + (ReqArg (\fl o -> o{optECHKeyFile = Just fl}) "") + "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 and \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 + }