tls-2.1.8/0000755000000000000000000000000007346545000010515 5ustar0000000000000000tls-2.1.8/CHANGELOG.md0000644000000000000000000005225307346545000012335 0ustar0000000000000000# Change log for "tls" ## 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 funcation, `validateClientCertificate`, for client authentication. * Bug fix for echo back logic of Cookie extension. * More pretty show for the internal `Handshake` structure for debugging. ## Version 2.1.6 * Testing with "tlsfuzzer" again. Now don't send an alert agaist to peer's alert. Double locking (aka self dead-lock) is fixed. Sending an alert for known-but-cannot-parse extensions. Other corner cases are also fixed. * `tls-client -d` and `tls-server -d` pretty-prints `Handshake`. ## Version 2.1.5 * Removing the dependency on the async package. * Restore a few DHE_RSA ciphers. [#493](https://github.com/haskell-tls/hs-tls/pull/493) ## Version 2.1.4 * Exporting defaultValidationCache. ## Version 2.1.3 * Remove `data-default` version constraint. [#492](https://github.com/haskell-tls/hs-tls/pull/492) * Exporting default variables. [#448](https://github.com/haskell-tls/hs-tls/pull/488) ## Version 2.1.2 * Using data-default instead of data-default-class. ## Version 2.1.1 * `bye` directly calls `timeout recvHS13`, not spawning a thread for `timeout recvHS13`. So, `bye` can receive an exception if thrown. ## Version 2.1.0 * Breaking change: stop exporting constructors to maintain future compatibilities. Field names are still exported, and values can be updated with them using record syntax. Use `def` and `noSessionManager` as initial values. * `onServerFinished` is added to `ClientHooks`. * `clientWantSessionResumeList` is added to `ClientParams` to support multiple tickets for TLS 1.3. ## Version 2.0.6 * Setting `supportedCiphers` in `defaultSupported` to `ciphersuite_default`. So, users don't have to override this value anymore by exporting `Network.TLS.Extra.Cipher`. [#471](https://github.com/haskell-tls/hs-tls/pull/471) * `ciphersuite_default` is the same as `ciphersuite_strong`. So, the duplicated definition is removed. * Add missing modules for util/tls-client and util/tls-server. ## Version 2.0.5 * Fixing handshake13_0rtt_fallback * Client checks if the group of PSK is contained in Supported_Groups. * HRR is not allowed for 0-RTT. ## Version 2.0.4 * More fix for 0-RTT when application data is available while receiving CF. * New util/tls-client and util/tls-server. ## Version 2.0.3 * Fixing a bug where `timeout` in `bye` does not work. * util/client -> util/tls-client * util/server -> util/tls-server ## Version 2.0.2 * Client checks sessionMaxEarlyDataSize to decide 0-RTT * Client checks the resumption cipher properly. ## Version 2.0.1 * Fix a leak of pending data to be sent. ## Version 2.0.0 * `tls` now only supports TLS 1.2 and TLS 1.3 with safe cipher suites. * Security: BREAKING CHANGE: TLS 1.0 and TLS 1.1 are removed. * Security: BREAKING CHANGE: all CBC cipher suite are removed. * Security: BREAKING CHANGE: RC4 and 3DES are removed. * Security: BREAKING CHANGE: DSS(digital signature standard) is removed. * Security: BREAKING CHANGE: TLS 1.2 servers require EMS(extended main secret) by default. `supportedExtendedMasterSec` is renamed to `supportedExtendedMainSecret`. * BREAKING CHANGE: the package is now complied with `Strict` and `StrictData`. * BREAKING CHANGE: Many data structures are re-defined with `PatternSynonyms` for extensibility. * BREAKING CHANGE: the structure of `SessionManager` is changed to support session tickets. * API: BREAKING CHANGE: `sendData` can send early data (0-RTT). `clientEarlyData` is removed. To send early data via `sendData`, set `clientUseEarlyData` to `True`. [#466](https://github.com/haskell-tls/hs-tls/issues/466) * API: `handshake` can receive an alert of client authentication failure for TLS 1.3. [#463](https://github.com/haskell-tls/hs-tls/pull/463) * API: `bye` can receive NewSessionTicket for TLS 1.3. * Channel binding: `getFinished` and `getPeerFinished` are deprecated. Use `getTLSUnique` instead. [#462](https://github.com/haskell-tls/hs-tls/pull/462) * Channel binding: `getTLSExporter` and `getTLSServerEndPoint` are provided. [#462](https://github.com/haskell-tls/hs-tls/pull/462) * Refactoring: the monolithic `handshake` is divided to follow the diagram of TLS 1.2 and 1.3 for readability. * Refactoring: test cases are refactored for maintenability and readablity. `hspec` is used instead of `tasty`. * Code format: `fourmolu` is used as an official formatter. * Catching up RFC8446bis-09. [#467](https://github.com/haskell-tls/hs-tls/issues/467) ## Version 1.9.0 * BREAKING CHANGE: The type of the `Error_Protocol` constructor of `TLSError` has changed. The "warning" case has been split off into a new `Error_Protocol_Warning` constructor. [#460](https://github.com/haskell-tls/hs-tls/pull/460) ## Version 1.8.0 * BREAKING CHANGE: Remove `Exception` instance for `TLSError`. The library now throws `TLSException` only. If you need to change your code, please refer to [this example](https://github.com/snoyberg/http-client/commit/73d1a4eb451c089878ba95e96371d0b18287ffb8) first. [#457](https://github.com/haskell-tls/hs-tls/pull/457) ## Version 1.7.1 * NOP on UserCanceled event [#454](https://github.com/haskell-tls/hs-tls/pull/454) ## Version 1.7.0 * Major version up because "crypton" is used instead of "cryptonite" ## Version 1.6.0 - Major version up because of disabling SSL3 - Some fixes against tlsfuzzer ## Version 1.5.8 - Require mtl-2.2.1 or newer [#448](https://github.com/haskell-tls/hs-tls/pull/448) ## Version 1.5.7 - New APIs: getFinished and getPeerFinished [#445](https://github.com/vincenthz/hs-tls/pull/445) ## Version 1.5.6 - Dynamically setting enctypted extensions [#444](https://github.com/vincenthz/hs-tls/pull/444) ## Version 1.5.5 - QUIC support [#419](https://github.com/vincenthz/hs-tls/pull/419) [#427](https://github.com/vincenthz/hs-tls/pull/427) [#428](https://github.com/vincenthz/hs-tls/pull/428) [#430](https://github.com/vincenthz/hs-tls/pull/430) [#433](https://github.com/vincenthz/hs-tls/pull/433) [#441](https://github.com/vincenthz/hs-tls/pull/441) - Server ECDSA for P-256 [#436](https://github.com/vincenthz/hs-tls/pull/436) - Sort ciphersuites based on hardware-acceleration support [#439](https://github.com/vincenthz/hs-tls/pull/439) - Sending no_application_protocol [#440](https://github.com/vincenthz/hs-tls/pull/440) - Internal improvements [#426](https://github.com/vincenthz/hs-tls/pull/426) [#431](https://github.com/vincenthz/hs-tls/pull/431) ## Version 1.5.4 - Restore interoperability with early Java 6 [#422](https://github.com/vincenthz/hs-tls/pull/422) - Test cleanups for timeout and async usage [#416](https://github.com/vincenthz/hs-tls/pull/416) ## Version 1.5.3 - Additional verification regarding EC signatures [#412](https://github.com/vincenthz/hs-tls/pull/412) - Fixing ALPN [#411](https://github.com/vincenthz/hs-tls/pull/411) - Check SSLv3 padding length [#410](https://github.com/vincenthz/hs-tls/pull/410) - Exposing getClientCertificateChain [#407](https://github.com/vincenthz/hs-tls/pull/407) - Extended Master Secret [#406](https://github.com/vincenthz/hs-tls/pull/406) - Brushing up the documentation [#404](https://github.com/vincenthz/hs-tls/pull/404) [#408](https://github.com/vincenthz/hs-tls/pull/408) - Improving tests [#403](https://github.com/vincenthz/hs-tls/pull/403) - Avoid calling onServerNameIndication twice with HRR [#402](https://github.com/vincenthz/hs-tls/pull/402) - Enable X448 and FFDHE groups [#401](https://github.com/vincenthz/hs-tls/pull/401) - Refactoring [#400](https://github.com/vincenthz/hs-tls/pull/400) [#399](https://github.com/vincenthz/hs-tls/pull/399) ## Version 1.5.2 - Enabled TLS 1.3 by default [#398](https://github.com/vincenthz/hs-tls/pull/398) - Avoid handshake failure with small RSA keys [#394](https://github.com/vincenthz/hs-tls/pull/394) NOTES: - Starting with tls-1.5.0, the parameter `supportedVersions` contains values ordered by decreasing preference, so typically the higher versions first. This departs from code samples previously available. For maximum interoperability, users overriding the default value should verify and adapt their code. ## Version 1.5.1 - Post-handshake authentication [#363](https://github.com/vincenthz/hs-tls/pull/363) - Middlebox compatibility [#386](https://github.com/vincenthz/hs-tls/pull/386) - Verification and configuration of session-ticket lifetime [#373](https://github.com/vincenthz/hs-tls/pull/373) - Fixing memory leak [#366](https://github.com/vincenthz/hs-tls/pull/366) - Don't send 0-RTT data when ticket is expired [#370](https://github.com/vincenthz/hs-tls/pull/370) - Handshake packet fragmentation [#371](https://github.com/vincenthz/hs-tls/pull/371) - Fix SSLv2 deprecated header [#383](https://github.com/vincenthz/hs-tls/pull/383) - Other improvements to TLS 1.3 and RFC conformance [#368](https://github.com/vincenthz/hs-tls/pull/368) [#372](https://github.com/vincenthz/hs-tls/pull/372) [#375](https://github.com/vincenthz/hs-tls/pull/375) [#376](https://github.com/vincenthz/hs-tls/pull/376) [#377](https://github.com/vincenthz/hs-tls/pull/377) [#378](https://github.com/vincenthz/hs-tls/pull/378) [#380](https://github.com/vincenthz/hs-tls/pull/380) [#382](https://github.com/vincenthz/hs-tls/pull/382) [#385](https://github.com/vincenthz/hs-tls/pull/385) [#387](https://github.com/vincenthz/hs-tls/pull/387) [#388](https://github.com/vincenthz/hs-tls/pull/388) ## Version 1.5.0 - Add and enable AES CCM ciphers [#271](https://github.com/vincenthz/hs-tls/pull/271) [#287](https://github.com/vincenthz/hs-tls/pull/287) - Verify certificate key usage [#274](https://github.com/vincenthz/hs-tls/pull/274) [#301](https://github.com/vincenthz/hs-tls/pull/301) - TLS 1.3 support [#278](https://github.com/vincenthz/hs-tls/pull/278) [#279](https://github.com/vincenthz/hs-tls/pull/279) [#280](https://github.com/vincenthz/hs-tls/pull/280) [#283](https://github.com/vincenthz/hs-tls/pull/283) [#298](https://github.com/vincenthz/hs-tls/pull/298) [#331](https://github.com/vincenthz/hs-tls/pull/331) [#290](https://github.com/vincenthz/hs-tls/pull/290) [#314](https://github.com/vincenthz/hs-tls/pull/314) - Enable RSASSA-PSS [#280](https://github.com/vincenthz/hs-tls/pull/280) [#353](https://github.com/vincenthz/hs-tls/pull/353) - Add and enable ChaCha20-Poly1305 ciphers [#287](https://github.com/vincenthz/hs-tls/pull/287) [#340](https://github.com/vincenthz/hs-tls/pull/340) - Certificate selection with extension "signature_algorithms_cert" [#302](https://github.com/vincenthz/hs-tls/pull/302) - Preventing Logjam attack [#300](https://github.com/vincenthz/hs-tls/pull/300) - Downgrade protection [#308](https://github.com/vincenthz/hs-tls/pull/308) - Support for EdDSA certificates [#328](https://github.com/vincenthz/hs-tls/pull/328) [#353](https://github.com/vincenthz/hs-tls/pull/353) - Key logging [#317](https://github.com/vincenthz/hs-tls/pull/317) - Thread safety for writes [#329](https://github.com/vincenthz/hs-tls/pull/329) - Verify signature schemes and (EC)DHE groups received [#337](https://github.com/vincenthz/hs-tls/pull/337) [#338](https://github.com/vincenthz/hs-tls/pull/338) - Throw BadRecordMac when the decrypted record has invalid format [#347](https://github.com/vincenthz/hs-tls/pull/347) - Improve documentation format [#341](https://github.com/vincenthz/hs-tls/pull/341) [#343](https://github.com/vincenthz/hs-tls/pull/343) - Fix recvClientData with single Handshake packet [#352](https://github.com/vincenthz/hs-tls/pull/352) - Decrease memory footprint of SessionData values [#354](https://github.com/vincenthz/hs-tls/pull/354) FEATURES: - TLS version 1.3 is available with most features but is not enabled by default. One notable omission is post-handshake authentication. Scenarios where servers previously used renegotiation to conditionally request a certificate are not possible yet when `TLS13` is negotiated. Users may enable the version in `supportedVersions` only when sure post-handshake authentication is not required. API CHANGES: - `SessionManager` implementations need to provide a `sessionResumeOnlyOnce` function to accomodate 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` values must deal with the new fields. - New configuration parameters and constructors are added for TLS version 1.3 but the API change should be backward compatible for most use-cases. - Function `cipherExchangeNeedMoreData` has been removed. ## Version 1.4.1 - Enable X25519 in default parameters [#265](https://github.com/vincenthz/hs-tls/pull/265) - Checking EOF in bye [#262](https://github.com/vincenthz/hs-tls/pull/262) - Improving validation in DH key exchange [#256](https://github.com/vincenthz/hs-tls/pull/256) - Handle TCP reset during handshake [#251](https://github.com/vincenthz/hs-tls/pull/251) - Accepting hlint suggestions. ## Version 1.4.0 - Wrap renegotiation failures with HandshakeFailed [#237](https://github.com/vincenthz/hs-tls/pull/237) - Improve selection of server certificate and use "signature_algorithms" extension [#236](https://github.com/vincenthz/hs-tls/pull/236) - Change Bytes to ByteString and deprecate the Bytes type alias [#230](https://github.com/vincenthz/hs-tls/pull/230) - Session compression and SNI [#223](https://github.com/vincenthz/hs-tls/pull/223) - Deprecating ciphersuite_medium. Putting WARNING to ciphersuite_all since this includes RC4 [#153](https://github.com/vincenthz/hs-tls/pull/153) [#222](https://github.com/vincenthz/hs-tls/pull/222) - Removing NPN [#214](https://github.com/vincenthz/hs-tls/pull/214) - Supporting RSAPSS defined in TLS 1.3 [#207](https://github.com/vincenthz/hs-tls/pull/207) - Supporting X25519 and X448 in the IES style. [#205](https://github.com/vincenthz/hs-tls/pull/205) - Strip leading zeros in DHE premaster secret [#201](https://github.com/vincenthz/hs-tls/pull/201) FEATURES: - RSASSA-PSS signatures can be enabled with `supportedHashSignatures`. This uses assignments from TLS 1.3, for example `(HashIntrinsic, SignatureRSApssSHA256)`. - Diffie-Hellman with elliptic curves X25519 and X448: This can be enabled with `supportedGroups`, which also gives control over curve preference. - ECDH with curve P-256 now uses optimized C implementation from package `cryptonite`. API CHANGES: - Cipher list `ciphersuite_medium` is now deprecated, users are advised to use `ciphersuite_default` or `ciphersuite_strong`. List `ciphersuite_all` is kept for compatibility with old servers but this is discouraged and generates a warning (this includes RC4 ciphers, see [#153](https://github.com/vincenthz/hs-tls/pull/153) for reference). - Support for NPN (Next Protocol Negotiation) has been removed. The replacement is ALPN (Application-Layer Protocol Negotiation). - Data type `SessionData` now contains fields for compression algorithm and client SNI. A `SessionManager` implementation that serializes/deserializes `SessionData` values must deal with the new fields. - Module `Network.TLS` exports a type alias named `Bytes` which is now deprecated. The replacement is to use strict `ByteString` directly. ## Version 1.3.11 - Using reliable versions of dependent libraries. ## Version 1.3.10 - Selecting a cipher based on "signature_algorithms" [#193](https://github.com/vincenthz/hs-tls/pull/193) - Respecting the "signature_algorithms" extension [#137](https://github.com/vincenthz/hs-tls/pull/137) - Fix RSA signature in CertificateVerify with TLS < 1.2 [#189](https://github.com/vincenthz/hs-tls/pull/189) - Fix ECDSA with TLS 1.0 / TLS 1.1 [#187](https://github.com/vincenthz/hs-tls/pull/187) - Sending an empty server name from a server if necessary. [#175](https://github.com/vincenthz/hs-tls/pull/175) - `Network.TLS.Extra` provides Finite Field Diffie-Hellman Ephemeral Parameters in RFC 7919 [#174](https://github.com/vincenthz/hs-tls/pull/174) - Restore ability to renegotiate[#164](https://github.com/vincenthz/hs-tls/pull/164) ## Version 1.3.9 - Drop support for old GHC. - Enable sha384 ciphers and provide `ciphersuite_default` as default set of ciphers for common needs [#168](https://github.com/vincenthz/hs-tls/pull/168) - SNI late checks [#147](https://github.com/vincenthz/hs-tls/pull/147) - Expose the HasBackend(..) class fully, so that developers can use TLS over their own channels [#149](https://github.com/vincenthz/hs-tls/pull/149) ## Version 1.3.8 - Fix older GHC builds ## Version 1.3.7 - Disable SHA384 based cipher, as they don't work properly yet. ## Version 1.3.6 - Add new ciphers - Improve some debugging and outputs ## Version 1.3.5 - Fix a bug with ECDHE based cipher where serialization - Debugging: Add a way to print random seed and a way to side-load a seed for replayability - Improve tests ## Version 1.3.4 - Fix tests on 32 bits `time_t` machines (time not within bound) - VirtualHost: Add a way to load credentials related to the hostname used by the client (Julian Beaumont) - VirtualHost: Expose an API to query which hostname the client has contacted (Julian Beaumont) - Add a way to disable empty packet that are use for security when using old versions + old CBC based cipher (Anton Dessiatov) ## Version 1.3.3 - Add support for Hans (Haskell Network Stack) (Adam Wick) - Add support for ECDSA signature - Add support for ECDSA-ECDHE Cipher - Improve parsing of ECC related structure ## Version 1.3.2 - Add cipher suites for forward secrecy on more clients (Aaron Friel) - Maintain more handshake information to be queried by protocol (Adam Wick) - handle SCSV on client and server side (Kazu Yamamoto) - Cleanup renegotiation logic (Kazu Yamamoto) - Various testing improvements with the openssl test parts - Cleanup AEAD handling for future support of other ciphers ## Version 1.3.1 - Repair DHE RSA handling on the cipher by creating signature properly ## Version 1.3.0 - modernize the crypto stack by using cryptonite. ## Version 1.2.18 - add more tests (network, local) - cleanup cipher / bulk code, certificate verify / creation, and digitall signed handling - fix handling of DHE ciphers with MS SSL stack that serialize leading zero. ## Version 1.2.17 - Fix an issue of type of key / hash that prevented connection with SChannel. ## Version 1.2.16 - Fix an issue with stream cipher not correctly calculating the internal state, resulting systematically in bad record mac failure during handshake ## Version 1.2.15 - support chain certificate in credentials ## Version 1.2.14 - adding ALPN extension - adding support for AEAD, and particularly AES128-GCM - Adding support for ECDH - Do not support SSL3 by default for security reason. - add EnumSafe8 and 16 for specific sized Enum instance that are safer - export signatureAndHash parser/encoder - add a "known" list of extensions - add SignatureAlgorithms extension - add Heartbeat extension - add support for EC curves and point format extensions - add preliminary SessionTicket extension - Debug: Add the ability to choose arbitrary cipher in the client hello. ## Version 1.2.13 - Fix compilation with old mtl version ## Version 1.2.12 - Propagate asynchronous exception ## Version 1.2.11 - use hourglass instead of time - use tasty instead of test-framework - add travis file - remove old de-optimisation flag as the bytestring bug is old now and it conflict with cabal check ## Version 1.2.10 - Update x509 dependencies ## Version 1.2.9 - Export TLSParams and HasBackend type names - Added FlexibleContexts flag required by ghc-7.9 - debug: add support for specifying the timeout length in milliseconds. - debug: add support for 3DES in simple client ## Version 1.2.8 - add support for 3DES-EDE-CBC-SHA1 (cipher 0xa) ## Version 1.2.7 - repair retrieve certificate validation, and improve fingerprints - remove groom from dependency - make RecordM an instance of Applicative - Fixes the Error_EOF partial pattern match error in exception handling ## Version 1.2.6 (23 Mar 2014) - Fixed socket backend endless loop when the server does not close connection properly at the TLS level with the close notify alert. - Catch Error_EOF in recvData and return empty data. ## Version 1.2.5 (23 Mar 2014) - Fixed Server key exchange data being parsed without the correct context, leading to not knowing how to parse the structure. The bug happens on efficient server that happens to send the ServerKeyXchg message together with the ServerHello in the same handshake packet. This trigger parsing of all the messages without having set the pending cipher. Delay parsing, when this happen, until we know what to do with it. ## Version 1.2.4 (23 Mar 2014) - Fixed unrecognized name non-fatal alert after client hello. - Add SSL3 to the supported list of version by default. - Fix cereal lower bound to 0.4.0 minimum ## Version 1.2.3 (22 Mar 2014) - Fixed handshake records not being able to span multiples records. tls-2.1.8/LICENSE0000644000000000000000000000273107346545000011525 0ustar0000000000000000Copyright (c) 2010-2015 Vincent Hanquez All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. tls-2.1.8/Network/0000755000000000000000000000000007346545000012146 5ustar0000000000000000tls-2.1.8/Network/TLS.hs0000644000000000000000000002014207346545000013143 0ustar0000000000000000-- | -- 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 TLS1.2 and TLS 1.3 -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions. -- -- The tipical usage is: -- -- > socket <- ... -- > ctx <- contextNew socket -- > handshake ctx -- > ... (using recvData and sendData) -- > bye module Network.TLS ( -- * Basic APIs Context, contextNew, handshake, sendData, recvData, bye, -- * Exceptions -- $exceptions -- * Backend abstraction HasBackend (..), Backend (..), -- * Parameters -- intentionally hide the internal methods even haddock warns. TLSParams, -- ** Client parameters ClientParams, defaultParamsClient, clientServerIdentification, clientUseServerNameIndication, clientWantSessionResume, clientWantSessionResumeList, clientShared, clientHooks, clientSupported, clientDebug, clientUseEarlyData, -- ** Server parameters ServerParams, defaultParamsServer, serverWantClientCert, serverCACertificates, serverDHEParams, serverHooks, serverShared, serverSupported, serverDebug, serverEarlyDataSize, serverTicketLifetime, -- ** Shared Shared, defaultShared, sharedCredentials, sharedSessionManager, sharedCAStore, sharedValidationCache, sharedHelloExtensions, sharedLimit, -- ** Client hooks ClientHooks, defaultClientHooks, OnCertificateRequest, onCertificateRequest, OnServerCertificate, onServerCertificate, validateClientCertificate, onSuggestALPN, onCustomFFDHEGroup, onServerFinished, -- ** Server hooks ServerHooks, defaultServerHooks, onClientCertificate, onUnverifiedClientCert, onCipherChoosing, onServerNameIndication, onNewHandshake, onALPNClientSuggest, onEncryptedExtensionsCreating, Measurement, nbHandshakes, bytesReceived, bytesSent, -- ** Supported Supported, defaultSupported, supportedVersions, supportedCiphers, supportedCompressions, supportedHashSignatures, supportedSecureRenegotiation, supportedClientInitiatedRenegotiation, supportedExtendedMainSecret, supportedSession, supportedFallbackScsv, supportedEmptyPacket, supportedGroups, -- ** Debug parameters DebugParams, defaultDebugParams, debugSeed, debugPrintSeed, debugVersionForced, debugKeyLogger, -- ** Limit parameters Limit, defaultLimit, limitHandshakeFragment, limitRecordSize, -- * Shared parameters -- ** Credentials Credentials (..), Credential, credentialLoadX509, credentialLoadX509FromMemory, credentialLoadX509Chain, credentialLoadX509ChainFromMemory, -- ** Session manager 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 (..), defaultValidationCache, ValidationCacheQueryCallback, ValidationCacheAddCallback, ValidationCacheResult (..), exceptionValidationCache, -- * Types -- ** For 'Supported' Version (..), Compression (..), nullCompression, HashAndSignatureAlgorithm, supportedSignatureSchemes, HashAlgorithm (..), SignatureAlgorithm (..), Group (..), supportedNamedGroups, EMSMode (..), -- ** For parameters and hooks DHParams, DHPublic, GroupUsage (..), CertificateUsage (..), CertificateRejectReason (..), CertificateType (..), CertificateChain (..), HostName, MaxFragmentEnum (..), -- * Advanced APIs -- ** Backend ctxBackend, contextFlush, contextClose, -- ** Information gathering Information, contextGetInformation, infoVersion, infoCipher, infoCompression, infoMainSecret, infoExtendedMainSecret, infoClientRandom, infoServerRandom, infoSupportedGroup, infoTLS12Resumption, infoTLS13HandshakeMode, infoIsEarlyDataAccepted, ClientRandom, ServerRandom, unClientRandom, unServerRandom, HandshakeMode13 (..), getClientCertificateChain, -- ** Negotiated getNegotiatedProtocol, getClientSNI, -- ** Post-handshake actions updateKey, KeyUpdateRequest (..), requestCertificate, getTLSUnique, getTLSExporter, getTLSServerEndPoint, getFinished, getPeerFinished, -- ** Modifying hooks in context 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 (..), -- ** Exceptions TLSException (..), -- * Raw types -- ** Compressions class CompressionC (..), CompressionID, -- ** Crypto Key PubKey (..), PrivKey (..), -- ** Ciphers & Predefined ciphers module Network.TLS.Cipher, -- * Deprecated recvData', Bytes, ValidationChecks (..), ValidationHooks (..), clientUseMaxFragmentLength, ) where import Network.TLS.Backend (Backend (..), HasBackend (..)) import Network.TLS.Cipher import Network.TLS.Compression ( Compression (..), CompressionC (..), nullCompression, ) import Network.TLS.Context import Network.TLS.Core import Network.TLS.Credentials import Network.TLS.Crypto ( DHParams, DHPublic, Group (..), KxError (..), supportedNamedGroups, ) import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Session import qualified Network.TLS.State as S 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 (PrivKey (..), PubKey (..)) import Data.X509.Validation hiding (HostName, defaultHooks) {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-} type Bytes = B.ByteString -- | Getting certificates from a client, if any. -- Note that the certificates are not sent by a client -- on resumption even if client authentication is required. -- So, this API would be replaced by the one which can treat -- both cases of full-negotiation and resumption. 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. tls-2.1.8/Network/TLS/0000755000000000000000000000000007346545000012610 5ustar0000000000000000tls-2.1.8/Network/TLS/Backend.hs0000644000000000000000000000361007346545000014473 0ustar0000000000000000-- | 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. -- -- Typically, a backend provides: -- * a way to read data -- * a way to write data -- * a way to close the stream -- * a way to flush the stream module Network.TLS.Backend ( HasBackend (..), Backend (..), ) where import qualified Data.ByteString as B import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network import Network.TLS.Imports import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) -- | 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. } class HasBackend a where initializeBackend :: a -> IO () getBackend :: a -> Backend instance HasBackend Backend where initializeBackend _ = return () getBackend = id safeRecv :: Network.Socket -> Int -> IO ByteString safeRecv = Network.recv 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) instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering getBackend handle = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle) tls-2.1.8/Network/TLS/Cipher.hs0000644000000000000000000000450207346545000014357 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_HADDOCK hide #-} 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 import Network.TLS.Crypto (Hash (..), hashDigestSize) import Network.TLS.Imports import Network.TLS.Types 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" bulkInit :: Bulk -> BulkDirection -> BulkKey -> BulkState bulkInit bulk direction key = case bulkF bulk of BulkBlockF ini -> BulkStateBlock (ini direction key) BulkStreamF ini -> BulkStateStream (ini direction key) BulkAeadF ini -> BulkStateAEAD (ini direction key) hasMAC, hasRecordIV :: BulkFunctions -> Bool hasMAC (BulkBlockF _) = True hasMAC (BulkStreamF _) = True hasMAC (BulkAeadF _) = False hasRecordIV = hasMAC cipherKeyBlockSize :: Cipher -> Int cipherKeyBlockSize cipher = 2 * (hashDigestSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk) 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 Just cVer -> cVer <= ver && (ver < TLS13 || cVer >= TLS13) eqCipher :: CipherID -> Cipher -> Bool eqCipher cid c = cipherID c == cid 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 tls-2.1.8/Network/TLS/Compression.hs0000644000000000000000000000463107346545000015451 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_HADDOCK hide #-} module Network.TLS.Compression ( CompressionC (..), Compression (..), CompressionID, nullCompression, NullCompression, -- * member redefined for the class abstraction compressionID, compressionDeflate, compressionInflate, -- * helper compressionIntersectID, ) where 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 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 -- | return the associated ID for this algorithm compressionID :: Compression -> CompressionID compressionID (Compression c) = compressionCID c -- | deflate (compress) a bytestring using a compression context and return the result -- along with the new compression context. compressionDeflate :: ByteString -> Compression -> (Compression, ByteString) compressionDeflate bytes (Compression c) = first Compression $ compressionCDeflate c bytes -- | inflate (decompress) a bytestring using a compression context and return the result -- along the new compression context. compressionInflate :: ByteString -> Compression -> (Compression, ByteString) compressionInflate bytes (Compression c) = first Compression $ compressionCInflate c bytes instance Show Compression where show = show . compressionID instance Eq Compression where (==) 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 -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l -- | This is the default compression which is a NOOP. data NullCompression = NullCompression instance CompressionC NullCompression where compressionCID _ = 0 compressionCDeflate s b = (s, b) compressionCInflate s b = (s, b) -- | default null compression nullCompression :: Compression nullCompression = Compression NullCompression tls-2.1.8/Network/TLS/Context.hs0000644000000000000000000002337007346545000014575 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Context ( -- * Context configuration TLSParams, -- * Context object and accessor Context (..), Hooks (..), Established (..), RecordLayer (..), ctxEOF, ctxEstablished, withLog, ctxWithHooks, contextModifyHooks, setEOF, setEstablished, contextFlush, contextClose, contextSend, contextRecv, updateMeasure, withMeasure, withReadLock, withWriteLock, withStateLock, withRWLock, -- * information Information (..), contextGetInformation, -- * New contexts contextNew, -- * Context hooks contextHookSetHandshakeRecv, contextHookSetHandshake13Recv, contextHookSetCertificateRecv, contextHookSetLogging, -- * Using context states 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.Crypto import Network.TLS.Handshake ( handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith, ) import Network.TLS.Handshake.State13 import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.Measurement import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.PostHandshake ( postHandshakeAuthClientWith, postHandshakeAuthServerWith, requestCertificateServer, ) import Network.TLS.RNG 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 (..), defaultRecordSizeLimit) import Network.TLS.X509 class TLSParams a where getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> Handshake -> IO () doRequestCertificate :: a -> Context -> IO Bool doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams = ( clientSupported cparams , clientShared cparams , clientDebug cparams ) getTLSRole _ = ClientRole doHandshake = handshakeClient doHandshakeWith = handshakeClientWith doRequestCertificate _ _ = return False doPostHandshakeAuthWith = postHandshakeAuthClientWith instance TLSParams ServerParams where getTLSCommonParams sparams = ( serverSupported sparams , serverShared sparams , serverDebug sparams ) getTLSRole _ = ServerRole doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer doPostHandshakeAuthWith = postHandshakeAuthServerWith -- | 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 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 let rng = newStateRNG seed let role = getTLSRole params st = newTLSState rng role tlsstate <- newMVar st eof <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement needEmptyPacket <- newIORef False hooks <- newIORef defaultHooks tx <- newMVar newRecordState rx <- newMVar newRecordState hs <- newMVar Nothing recvActionsRef <- newIORef [] sendActionRef <- newIORef Nothing crs <- newIORef [] locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State mylimref <- newRecordLimitRef $ Just defaultRecordSizeLimit peerlimref <- newRecordLimitRef $ Just defaultRecordSizeLimit let roleParams = RoleParams { doHandshake_ = doHandshake params , doHandshakeWith_ = doHandshakeWith params , doRequestCertificate_ = doRequestCertificate params , doPostHandshakeAuthWith_ = doPostHandshakeAuthWith params } let ctx = Context { ctxBackend = getBackend backend , ctxShared = shared , ctxSupported = supported , 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 , ctxCertRequests = crs , ctxKeyLogger = debugKeyLogger debug , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp , ctxQUICMode = False , ctxTLS13State = st13ref } syncNoOp _ _ = return () recordLayer = RecordLayer { recordEncode12 = encodeRecord12 , recordEncode13 = encodeRecord13 , recordSendBytes = sendBytes , recordRecv12 = recvRecord12 , recordRecv13 = recvRecord13 } return ctx contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f = contextModifyHooks context (\hooks -> hooks{hookRecvHandshake = f}) contextHookSetHandshake13Recv :: Context -> (Handshake13 -> IO Handshake13) -> IO () contextHookSetHandshake13Recv context f = contextModifyHooks context (\hooks -> hooks{hookRecvHandshake13 = f}) contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO () contextHookSetCertificateRecv context f = contextModifyHooks context (\hooks -> hooks{hookRecvCertificates = f}) contextHookSetLogging :: Context -> Logging -> IO () contextHookSetLogging context loggingCallbacks = contextModifyHooks context (\hooks -> hooks{hookLogging = loggingCallbacks}) {-# DEPRECATED getFinished "Use getTLSUnique instead" #-} -- | 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 "" 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 tls-2.1.8/Network/TLS/Context/0000755000000000000000000000000007346545000014234 5ustar0000000000000000tls-2.1.8/Network/TLS/Context/Internal.hs0000644000000000000000000004163007346545000016350 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Context.Internal ( -- * Context configuration ClientParams (..), ServerParams (..), defaultParamsClient, SessionID, SessionData (..), MaxFragmentEnum (..), Measurement (..), -- * Context object and accessor 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, -- * Using context states throwCore, failOnEitherError, usingState, usingState_, runTxRecordState, runRxRecordState, usingHState, getHState, saveHState, restoreHState, getStateRNG, tls13orLater, addCertRequest13, getCertRequest13, decideRecordVersion, -- * Misc HandshakeSync (..), TLS13State (..), defaultTLS13State, getTLS13State, modifyTLS13State, CipherChoice (..), makeCipherChoice, -- * RecordLimit setMyRecordLimit, enableMyRecordLimit, getMyRecordLimit, checkMyRecordLimit, setPeerRecordLimit, enablePeerRecordLimit, getPeerRecordLimit, checkPeerRecordLimit, newRecordLimitRef, ) where 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 import Network.TLS.Backend import Network.TLS.Cipher import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Control import Network.TLS.Handshake.State import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Record import Network.TLS.Record.State import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Util -- | 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 , 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 , ctxKeyLogger :: String -> IO () , ctxHooks :: IORef Hooks , -- TLS 1.3 ctxTLS13State :: IORef TLS13State , ctxPendingRecvActions :: IORef [PendingRecvAction] , ctxPendingSendAction :: IORef (Maybe (Context -> IO ())) , ctxCertRequests :: IORef [Handshake13] -- ^ pending post handshake authentication requests , -- QUIC ctxRecordLayer :: RecordLayer a , 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 } data RecordLimit = NoRecordLimit -- for QUIC | RecordLimit Int -- effective (Maybe Int) -- pending deriving (Eq, Show) data RoleParams = RoleParams { doHandshake_ :: Context -> IO () , doHandshakeWith_ :: Context -> Handshake -> IO () , doRequestCertificate_ :: Context -> IO Bool , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> 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. } data CipherChoice = CipherChoice { cVersion :: Version , cCipher :: Cipher , cHash :: Hash , cZero :: ByteString } deriving (Show) makeCipherChoice :: Version -> Cipher -> CipherChoice makeCipherChoice ver cipher = CipherChoice ver cipher h zero where h = cipherHash cipher zero = B.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 -- Actuall 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, ..} 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 PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment. PendingRecvAction Bool (Handshake13 -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment. PendingRecvActionHash Bool (ByteString -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx) withMeasure :: Context -> (Measurement -> IO a) -> IO a withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f -- | A shortcut for 'backendFlush . ctxBackend'. contextFlush :: Context -> IO () contextFlush = backendFlush . ctxBackend -- | A shortcut for 'backendClose . ctxBackend'. contextClose :: Context -> IO () contextClose = backendClose . ctxBackend -- | Information about the current context contextGetInformation :: Context -> IO (Maybe Information) contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx let (ms, ems, cr, sr, hm13, grp) = case hstate of Just st -> ( hstMainSecret st , hstExtendedMainSecret st , Just (hstClientRandom st) , hstServerRandom st , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing , hstSupportedGroup st ) Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing) (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 { infoVersion = v , infoCipher = c , infoCompression = comp , infoMainSecret = ms , infoExtendedMainSecret = ems , infoClientRandom = cr , infoServerRandom = sr , infoSupportedGroup = grp , infoTLS12Resumption = tls12resumption , infoTLS13HandshakeMode = hm13 , infoIsEarlyDataAccepted = accepted } _ -> return Nothing contextSend :: Context -> ByteString -> IO () 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 $ ctxBackend c) sz ctxEOF :: Context -> IO Bool ctxEOF ctx = readIORef $ ctxEOF_ ctx setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True ctxEstablished :: Context -> IO Established ctxEstablished ctx = readIORef $ ctxEstablished_ ctx ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO () contextModifyHooks ctx = modifyIORef (ctxHooks ctx) setEstablished :: Context -> Established -> IO () setEstablished ctx = writeIORef (ctxEstablished_ ctx) withLog :: Context -> (Logging -> IO ()) -> IO () withLog ctx f = ctxWithHooks ctx (f . hookLogging) throwCore :: MonadIO m => TLSError -> m a throwCore = liftIO . throwIO . Uncontextualized failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a failOnEitherError f = do ret <- f case ret of Left err -> throwCore err Right r -> return r usingState :: Context -> TLSSt a -> IO (Either TLSError a) usingState ctx f = 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 (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 (ctxHandshakeState ctx) saveHState :: Context -> IO (Saved (Maybe HandshakeState)) saveHState ctx = saveMVar (ctxHandshakeState 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 ver <- getVersionWithDefault (maximum $ supportedVersions $ ctxSupported ctx) hrr <- getTLS13HRR -- For TLS 1.3, ver' is only used in ClientHello. -- 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 return (ver', ver >= TLS13) runTxRecordState :: Context -> RecordM a -> IO (Either TLSError a) runTxRecordState ctx f = do (ver, tls13) <- decideRecordVersion ctx let opt = RecordOptions { recordVersion = ver , recordTLS13 = tls13 } modifyMVar (ctxTxRecordState ctx) $ \st -> case runRecordM f opt st of Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) 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 (ctxRxRecordState ctx) $ \st -> case runRecordM f opt st of 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 (lockRead $ ctxLocks ctx) (const f) withWriteLock :: Context -> IO a -> IO a 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 (lockState $ ctxLocks ctx) (const f) tls13orLater :: MonadIO m => Context -> m Bool tls13orLater ctx = do ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS12 return $ case ev of Left _ -> False Right v -> v >= TLS13 addCertRequest13 :: Context -> Handshake13 -> IO () addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq :) getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13) getCertRequest13 ctx context = do let ref = ctxCertRequests ctx l <- readIORef ref let (matched, others) = partition (\cr -> context == fromCertRequest13 cr) l case matched of [] -> return Nothing (certReq : _) -> writeIORef ref others >> return (Just certReq) where fromCertRequest13 (CertRequest13 c _) = c fromCertRequest13 _ = error "fromCertRequest13" -------------------------------- 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 tls-2.1.8/Network/TLS/Core.hs0000644000000000000000000005433407346545000014045 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} module Network.TLS.Core ( -- * Internal packet sending and receiving sendPacket12, recvPacket12, -- * Initialisation and Termination of context bye, handshake, -- * Application Layer Protocol Negotiation getNegotiatedProtocol, -- * Server Name Indication getClientSNI, -- * High level API sendData, recvData, recvData', updateKey, KeyUpdateRequest (..), requestCertificate, ) where 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.Cipher import Network.TLS.Context import Network.TLS.Crypto 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.State import Network.TLS.Handshake.State13 import Network.TLS.IO import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.Parameters import Network.TLS.PostHandshake import Network.TLS.Session import Network.TLS.State (getRole, getSession) import qualified Network.TLS.State as S import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types ( AnyTrafficSecret (..), ApplicationSecret, HostName, Role (..), ) import Network.TLS.Util (catchException, mapChunks_) -- | 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} 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. -- -- 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 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 ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol -- | If the Server Name Indication extension has been used, return the -- hostname specified by the client. 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 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. mlen <- getPeerRecordLimit ctx -- plaintext, dont' 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 ctx = liftIO $ do tls13 <- tls13orLater ctx withReadLock ctx $ do checkValid ctx -- We protect with a read lock both reception and processing of the -- packet, because don't want another thread to receive a new packet -- before this one has been fully processed. -- -- 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 recvData12 ctx recvData12 :: Context -> IO B.ByteString recvData12 ctx = do pkt <- recvPacket12 ctx either (onError terminate12) process pkt where process (Handshake [ch@ClientHello{}]) = handshakeWith ctx ch >> recvData12 ctx process (Handshake [hr@HelloRequest]) = handshakeWith ctx hr >> recvData12 ctx -- 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 "") = recvData12 ctx process (AppData x) = return x process p = let reason = "unexpected message " ++ show p in terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason terminate12 = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) recvData13 :: Context -> IO B.ByteString recvData13 ctx = do 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) = 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 | chunkLen <= maxSize -> do setEstablished ctx $ EarlyDataAllowed (maxSize - chunkLen) return x | otherwise -> let reason = "early data overflow" in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x" | otherwise -> let reason = "early data deprotect overflow" in 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" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason process p = let reason = "unexpected message " ++ show p in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. loopHandshake13 (NewSessionTicket13 life add nonce ticket exts : hs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ let reason = "Session ticket is allowed for client only" in 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 hs loopHandshake13 (KeyUpdate13 mode : hs) = do let multipleKeyUpdate = any isKeyUpdate13 hs when multipleKeyUpdate $ do let reason = "Multiple KeyUpdate is not allowed in one record" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason checkAlignment ctx 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 getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] keyUpdate ctx getTxRecordState setTxRecordState loopHandshake13 hs else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 (h@CertRequest13{} : hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h@Certificate13{} : hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h : hs) = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of ServerHello13 srand _ _ _ -> when (isHelloRetryRequest srand) $ do clearTxRecordState ctx let reason = "HRR is not allowed for 0-RTT" in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return () cont <- popAction ctx h hs when cont $ loopHandshake13 hs 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) = do loopHandshake13 hs stop <- breakLoop unless stop $ recvHS13 ctx breakLoop process _ = recvHS13 ctx breakLoop 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 ticket exts : hs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ let reason = "Session ticket is allowed for client only" in 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 hs loopHandshake13 (h : hs) = do cont <- popAction ctx h hs when cont $ loopHandshake13 hs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool popAction ctx h hs = do 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 hs processHandshake13 ctx h pa h PendingRecvActionHash needAligned pa -> do when needAligned $ checkAlignment ctx hs d <- transcriptHash ctx processHandshake13 ctx h pa d h -- Client: after receiving SH, app data is coming. -- this loop tries to receive it. -- App key must be installed before receiving -- the app data. sendCFifNecessary ctx return True checkAlignment :: Context -> [Handshake13] -> IO () checkAlignment ctx _hs = 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 ()) 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) 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) -> -- calling even session ticket manager anyway sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx 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 = -- | Unidirectional key update OneWay | -- | Bidirectional key update (normal case) TwoWay deriving (Eq, Show) -- | Updating appication traffic secrets for TLS 1.3. -- If this API is called for TLS 1.3, 'True' is returned. -- Otherwise, 'False' is returned. updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool updateKey ctx way = liftIO $ do tls13 <- tls13orLater ctx when tls13 $ do let req = case way of OneWay -> UpdateNotRequested TwoWay -> UpdateRequested -- Write lock wraps both actions because we don't want another packet to -- be sent by another thread before the Tx state is updated. withWriteLock ctx $ do sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] keyUpdate ctx getTxRecordState setTxRecordState return tls13 tls-2.1.8/Network/TLS/Credentials.hs0000644000000000000000000001634007346545000015405 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.TLS.Credentials ( Credential, Credentials (..), credentialLoadX509, credentialLoadX509FromMemory, credentialLoadX509Chain, credentialLoadX509ChainFromMemory, credentialsFindForSigning, credentialsFindForDecrypting, credentialsListSigningAlgorithms, credentialPublicPrivateKeys, credentialMatchesHashSignatures, ) where import Data.X509 import Data.X509.File import Data.X509.Memory import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.X509 import qualified Data.X509 as X509 import qualified Network.TLS.Struct as TLS type Credential = (CertificateChain, PrivKey) instance {-# OVERLAPS #-} Show Credential where show (cc, _) = TLS.showCertificateChain cc newtype Credentials = Credentials [Credential] deriving (Show) instance Semigroup Credentials where Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2) instance Monoid Credentials where mempty = Credentials [] #if !(MIN_VERSION_base(4,11,0)) mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2) #endif -- | 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 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 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 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) -- | similar to 'credentialLoadX509FromMemory' but also allow -- specifying chain certificates. credentialLoadX509ChainFromMemory :: ByteString -> [ByteString] -> ByteString -> Either String Credential credentialLoadX509ChainFromMemory certData chainData privateData = let x509 = readSignedObjectFromMemory certData chains = map readSignedObjectFromMemory chainData keys = readKeyFileFromMemory privateData in case keys of [] -> 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 kxsAlg (Credentials l) = find forSigning l 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 -- 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 -- this change in future. credentialCanDecrypt :: Credential -> Maybe () credentialCanDecrypt (chain, priv) = case (pub, priv) of (PubKeyRSA _, PrivKeyRSA _) -> case extensionGet (certExtensions cert) of Nothing -> Just () Just (ExtKeyUsage flags) | KeyUsage_keyEncipherment `elem` flags -> Just () | 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) Just (ExtKeyUsage flags) | 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 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.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 where convertHash sig X509.HashMD5 = Just (TLS.HashMD5, sig) convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1, sig) convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig) convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig) convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig) convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig) convertHash _ _ = Nothing -- | 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 hashSigs (chain, _) = case chain of CertificateChain [] -> True CertificateChain (leaf : _) -> isSelfSigned leaf || matchHashSig leaf where matchHashSig signed = case getHashSignature signed of Nothing -> False Just hs -> hs `elem` hashSigs isSelfSigned signed = let cert = getCertificate signed in certSubjectDN cert == certIssuerDN cert tls-2.1.8/Network/TLS/Crypto.hs0000644000000000000000000004067207346545000014435 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} module Network.TLS.Crypto ( HashContext, HashCtx, hashInit, hashUpdate, hashUpdateSSL, hashFinal, module Network.TLS.Crypto.DH, module Network.TLS.Crypto.IES, module Network.TLS.Crypto.Types, -- * Hash hash, 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 import qualified Crypto.ECC as ECDSA import Crypto.Error import qualified Crypto.Hash as H import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA_ECC import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random import qualified Data.ByteArray as B (convert) import qualified Data.ByteString as B 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.BinaryEncoding (BER (..), DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types import Data.Proxy {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-} type PrivateKey = PrivKey data KxError = RSAError RSA.Error | KxUnsupported deriving (Show) isKeyExchangeSignatureKey :: KeyExchangeSignatureAlg -> PubKey -> Bool isKeyExchangeSignatureKey = f where 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 keyPair = case keyPair of (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 prms = fromJust $ dhParamsForGroup grp ] findEllipticCurveGroup :: PubKeyEC -> Maybe Group findEllipticCurveGroup ecPub = case ecPubKeyCurveName ecPub of Just ECC.SEC_p256r1 -> Just P256 Just ECC.SEC_p384r1 -> Just P384 Just ECC.SEC_p521r1 -> Just P521 _ -> 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 SHA1_MD5 = HashContextSSL H.hashInit H.hashInit hashUpdate :: HashContext -> B.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 hashUpdateSSL (HashContext _) _ = error "internal error: update SSL without a SSL Context" hashUpdateSSL (HashContextSSL sha1Ctx md5Ctx) (b1, b2) = HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) hashFinal :: HashCtx -> B.ByteString hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) = B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 deriving (Show, Eq) 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) 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 hashName :: Hash -> String hashName = show -- | Digest size in bytes. hashDigestSize :: Hash -> Int hashDigestSize MD5 = 16 hashDigestSize SHA1 = 20 hashDigestSize SHA224 = 28 hashDigestSize SHA256 = 32 hashDigestSize SHA384 = 48 hashDigestSize SHA512 = 64 hashDigestSize SHA1_MD5 = 36 hashBlockSize :: Hash -> Int hashBlockSize MD5 = 64 hashBlockSize SHA1 = 64 hashBlockSize SHA224 = 64 hashBlockSize SHA256 = 64 hashBlockSize SHA384 = 128 hashBlockSize SHA512 = 128 hashBlockSize SHA1_MD5 = 64 {- 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 (Right x) = Right x kxEncrypt :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) 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. kxCanUseRSApkcs1 :: RSA.PublicKey -> Hash -> Bool kxCanUseRSApkcs1 pk h = RSA.public_size pk >= tLen + 11 where tLen = prefixSize h + hashDigestSize h 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") -- | Test the RSASSA-PSS length condition described in RFC 8017 section 9.1.1, -- i.e. @emBits >= 8hLen + 8sLen + 9@. Lengths are in bits. kxCanUseRSApss :: RSA.PublicKey -> Hash -> Bool kxCanUseRSApss pk h = numBits (RSA.public_n pk) >= 16 * hashDigestSize h + 10 -- Signature algorithm and associated parameters. -- -- FIXME add RSAPSSParams data SignatureParams = RSAParams Hash RSAEncoding | DSAParams | ECDSAParams Hash | Ed25519Params | Ed448Params 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) DSAParams msg signBS = case dsaToSignature signBS of Just sig -> DSA.verify H.SHA1 pk sig msg _ -> False where dsaToSignature :: ByteString -> Maybe DSA.Signature dsaToSignature b = case decodeASN1' BER b of Left _ -> Nothing Right asn1 -> case asn1 of Start Sequence : IntVal r : IntVal s : End Sequence : _ -> Just DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} _ -> Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ join $ withPubKeyEC key verifyProxy verifyClassic Nothing where decodeSignatureASN1 buildRS = case decodeASN1' BER sigBS of Left _ -> Nothing Right [Start Sequence, IntVal r, IntVal s, End Sequence] -> Just (buildRS r s) Right _ -> Nothing verifyProxy prx pubkey = do rs <- decodeSignatureASN1 (,) signature <- maybeCryptoError $ ECDSA.signatureFromIntegers prx rs verifyF <- withAlg (ECDSA.verify prx) return $ verifyF pubkey signature msg verifyClassic pubkey = do 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 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 kxVerify (PubKeyEd25519 key) Ed25519Params msg sigBS = case Ed25519.signature sigBS of CryptoPassed sig -> Ed25519.verify key msg sig _ -> False kxVerify (PubKeyEd448 key) Ed448Params msg sigBS = case Ed448.signature sigBS of CryptoPassed sig -> Ed448.verify key msg sig _ -> False kxVerify _ _ _ _ = False -- Sign the given message using the private key. -- 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 _) 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 ] kxSign (PrivKeyEC pk) (PubKeyEC _) (ECDSAParams hashAlg) msg = case withPrivKeyEC pk doSign (const unsupported) unsupported of 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 kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg = return $ Right $ B.convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg = return $ Right $ B.convert $ Ed448.sign pk pub msg kxSign _ _ _ _ = return (Left KxUnsupported) 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 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" 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) rsapssVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsapssVerifyHash SHA256 = PSS.verify (PSS.defaultPSSParams H.SHA256) rsapssVerifyHash SHA384 = PSS.verify (PSS.defaultPSSParams H.SHA384) rsapssVerifyHash SHA512 = PSS.verify (PSS.defaultPSSParams H.SHA512) rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" noHash :: Maybe H.MD5 noHash = Nothing ecdsaSignHash :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve) => 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 -- 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 pubkey withProxy withClassic whenUnknown = case ecPubKeyCurveName pubkey of Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> maybeCryptoError $ withProxy p256 <$> ECDSA.decodePublic p256 bs Just curveName -> let curve = ECC.getCurveByName curveName pub = unserializePoint curve pt in withClassic . ECDSA_ECC.PublicKey curve <$> pub 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 privkey withProxy withUnsupported whenUnknown = case ecPrivKeyCurveName privkey of 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 p256 :: Proxy ECDSA.Curve_P256R1 p256 = Proxy tls-2.1.8/Network/TLS/Crypto/0000755000000000000000000000000007346545000014070 5ustar0000000000000000tls-2.1.8/Network/TLS/Crypto/DH.hs0000644000000000000000000000400407346545000014715 0ustar0000000000000000module Network.TLS.Crypto.DH ( -- * DH types DHParams, DHPublic, DHPrivate, DHKey, -- * DH methods 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 qualified Data.ByteArray as B import Network.TLS.RNG type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params type DHKey = DH.SharedKey dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber dhPrivate :: Integer -> DHPrivate dhPrivate = DH.PrivateNumber dhParams :: Integer -> Integer -> DHParams dhParams p g = DH.Params p g (numBits p) dhGenerateKeyPair :: MonadRandom r => DHParams -> r (DHPrivate, DHPublic) dhGenerateKeyPair params = do priv <- DH.generatePrivate params let pub = DH.calculatePublic params priv return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey dhGetShared params priv pub = stripLeadingZeros (DH.getShared params priv pub) where -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3. stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb) -- 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. -- This verification is enough when using a safe prime. dhValid :: DHParams -> Integer -> Bool 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] dhParamsGetP :: DHParams -> Integer dhParamsGetP (DH.Params p _ _) = p dhParamsGetG :: DHParams -> Integer dhParamsGetG (DH.Params _ g _) = g dhParamsGetBits :: DHParams -> Int dhParamsGetBits (DH.Params _ _ b) = b dhUnwrapPublic :: DHPublic -> Integer dhUnwrapPublic (DH.PublicNumber y) = y tls-2.1.8/Network/TLS/Crypto/IES.hs0000644000000000000000000002640107346545000015047 0ustar0000000000000000-- | -- Module : Network.TLS.Crypto.IES -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown module Network.TLS.Crypto.IES ( GroupPublic, GroupPrivate, GroupKey, -- * Group methods groupGenerateKeyPair, groupGetPubShared, groupGetShared, encodeGroupPublic, decodeGroupPublic, -- * Compatibility with 'Network.TLS.Crypto.DH' dhParamsForGroup, dhGroupGenerateKeyPair, dhGroupGetPubShared, ) where import Control.Arrow import Crypto.ECC import Crypto.Error import Crypto.Number.Generate import Crypto.PubKey.DH hiding (generateParams) import Crypto.PubKey.ECIES import qualified Data.ByteArray as B import Data.Proxy import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Util.Serialization (i2ospOf_, os2ip) 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) 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) type GroupKey = SharedSecret p256 :: Proxy Curve_P256R1 p256 = Proxy p384 :: Proxy Curve_P384R1 p384 = Proxy p521 :: Proxy Curve_P521R1 p521 = Proxy x25519 :: Proxy Curve_X25519 x25519 = Proxy x448 :: Proxy Curve_X448 x448 = Proxy dhParamsForGroup :: Group -> Maybe Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096 dhParamsForGroup FFDHE6144 = Just ffdhe6144 dhParamsForGroup FFDHE8192 = Just ffdhe8192 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 X25519 = (GroupPri_X255, GroupPub_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 groupGenerateKeyPair _ = error "groupGenerateKeyPair" dhGroupGenerateKeyPair :: MonadRandom r => Group -> r (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) addParams :: Functor f => Params -> f (a, b) -> f (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) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) gen :: MonadRandom r => Params -> Int -> (PrivateNumber -> GroupPrivate) -> (PublicNumber -> GroupPublic) -> r (GroupPrivate, GroupPublic) 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 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 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 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) getPubShared' :: MonadRandom r => Params -> Int -> PublicNumber -> r (Maybe (PublicNumber, SharedKey)) getPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits let share = stripLeadingZeros (getShared params mypri pub) return $ Just (calculatePublic params mypri, SharedKey share) 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 calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret calcShared params pub pri | valid params pub = Just $ SharedSecret share | otherwise = Nothing where SharedKey share = 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 enc :: Params -> PublicNumber -> ByteString enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs decodeGroupPublic _ _ = error "decodeGroupPublic" -- 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 -- strips leading zeros from the result of getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3. stripLeadingZeros :: SharedKey -> B.ScrubbedBytes stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber generatePriv e = PrivateNumber <$> generateParams e (Just SetHighest) False -- Short exponent bit sizes from RFC 7919 appendix A, rounded to next -- multiple of 16 bits, i.e. going through a function like: -- let shortExp n = head [ e | i <- [1..], let e = n + i, e `mod` 16 == 0 ] exp2048 :: Int exp3072 :: Int exp4096 :: Int exp6144 :: Int exp8192 :: Int exp2048 = 240 -- shortExp 225 exp3072 = 288 -- shortExp 275 exp4096 = 336 -- shortExp 325 exp6144 = 384 -- shortExp 375 exp8192 = 416 -- shortExp 400 tls-2.1.8/Network/TLS/Crypto/Types.hs0000644000000000000000000000435207346545000015534 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternSynonyms #-} -- | -- Module : Network.TLS.Crypto.Types -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown module Network.TLS.Crypto.Types ( Group ( Group, P256, P384, P521, X25519, X448, FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192 ), availableFFGroups, availableECGroups, supportedNamedGroups, KeyExchangeSignatureAlg (..), ) where 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 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 (Group x) = "Group " ++ show x {- FOURMOLU_ENABLE -} availableFFGroups :: [Group] availableFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192] availableECGroups :: [Group] availableECGroups = [P256, P384, P521, X25519, X448] supportedNamedGroups :: [Group] supportedNamedGroups = [ X25519 , X448 , P256 , FFDHE2048 , FFDHE3072 , FFDHE4096 , P384 , FFDHE6144 , FFDHE8192 , P521 ] -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3). data KeyExchangeSignatureAlg = KX_RSA | KX_DSA | KX_ECDSA deriving (Show, Eq) tls-2.1.8/Network/TLS/ErrT.hs0000644000000000000000000000052207346545000014017 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | 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) runErrT = runExceptT type ErrT = ExceptT tls-2.1.8/Network/TLS/Error.hs0000644000000000000000000002252107346545000014237 0ustar0000000000000000{-# 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 instance Show AlertDescription where show CloseNotify = "CloseNotify" show UnexpectedMessage = "UnexpectedMessage" show BadRecordMac = "BadRecordMac" show DecryptionFailed = "DecryptionFailed" show RecordOverflow = "RecordOverflow" show DecompressionFailure = "DecompressionFailure" show HandshakeFailure = "HandshakeFailure" show BadCertificate = "BadCertificate" show UnsupportedCertificate = "UnsupportedCertificate" show CertificateRevoked = "CertificateRevoked" show CertificateExpired = "CertificateExpired" show CertificateUnknown = "CertificateUnknown" show IllegalParameter = "IllegalParameter" show UnknownCa = "UnknownCa" show AccessDenied = "AccessDenied" show DecodeError = "DecodeError" show DecryptError = "DecryptError" show ExportRestriction = "ExportRestriction" show ProtocolVersion = "ProtocolVersion" show InsufficientSecurity = "InsufficientSecurity" show InternalError = "InternalError" show InappropriateFallback = "InappropriateFallback" show UserCanceled = "UserCanceled" show NoRenegotiation = "NoRenegotiation" show MissingExtension = "MissingExtension" show UnsupportedExtension = "UnsupportedExtension" show CertificateUnobtainable = "CertificateUnobtainable" show UnrecognizedName = "UnrecognizedName" show BadCertificateStatusResponse = "BadCertificateStatusResponse" show BadCertificateHashValue = "BadCertificateHashValue" show UnknownPskIdentity = "UnknownPskIdentity" show CertificateRequired = "CertificateRequired" show GeneralError = "GeneralError" show NoApplicationProtocol = "NoApplicationProtocol" show (AlertDescription x) = "AlertDescription " ++ show x {- FOURMOLU_ENABLE -} tls-2.1.8/Network/TLS/Extension.hs0000644000000000000000000012207407346545000015126 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -- | 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_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 (..), ) where import qualified Control.Exception as E import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.X509 (DistinguishedName) 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_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_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_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_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) = show eid ++ " " ++ showBytesHex bs 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_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 dependant 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, Show) data PreSharedKey = PreSharedKeyClientHello [PskIdentity] [ByteString] | PreSharedKeyServerHello Int deriving (Eq, Show) instance Extension PreSharedKey where extensionID _ = EID_PreSharedKey extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do putOpaque16 $ runPut (mapM_ putIdentity ids) putOpaque16 $ runPut (mapM_ putBinder bds) where putIdentity (PskIdentity bs w) = do putOpaque16 bs putWord32 w putBinder = putOpaque8 extensionEncode (PreSharedKeyServerHello w16) = runPut $ putWord16 $ fromIntegral w16 extensionDecode MsgTServerHello = runGetMaybe $ PreSharedKeyServerHello . fromIntegral <$> getWord16 extensionDecode MsgTClientHello = runGetMaybe $ do len1 <- fromIntegral <$> getWord16 identities <- getList len1 getIdentity len2 <- fromIntegral <$> getWord16 binders <- getList len2 getBinder return $ PreSharedKeyClientHello identities binders where getIdentity = do identity <- getOpaque16 age <- getWord32 let len = 2 + B.length identity + 4 return (len, PskIdentity identity age) getBinder = do l <- fromIntegral <$> getWord8 binder <- getBytes l let len = l + 1 return (len, binder) extensionDecode _ = error "extensionDecode: PreShareKey" ------------------------------------------------------------ newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32) deriving (Eq, Show) instance Extension EarlyDataIndication where extensionID _ = EID_EarlyData extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32 extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing) extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing) extensionDecode MsgTNewSessionTicket = runGetMaybe $ EarlyDataIndication . Just <$> getWord32 extensionDecode _ = error "extensionDecode: EarlyDataIndication" ------------------------------------------------------------ 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) = "KeyShare " ++ 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 ------------------------------------------------------------ -- | 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" tls-2.1.8/Network/TLS/Extension.hs-boot0000644000000000000000000000127507346545000016066 0ustar0000000000000000-- 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} tls-2.1.8/Network/TLS/Extra.hs0000644000000000000000000000031407346545000014225 0ustar0000000000000000-- | 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 tls-2.1.8/Network/TLS/Extra/0000755000000000000000000000000007346545000013673 5ustar0000000000000000tls-2.1.8/Network/TLS/Extra/Cipher.hs0000644000000000000000000006576507346545000015464 0ustar0000000000000000module 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 qualified Data.ByteString as B import Data.Tuple (swap) import Network.TLS.Cipher import Network.TLS.Types 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 ---------------------------------------------------------------- -- | 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 -> 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 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} tls-2.1.8/Network/TLS/Extra/FFDHE.hs0000644000000000000000000001704407346545000015051 0ustar0000000000000000-- | -- Module : Network.TLS.Extra -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown -- -- Finite Field Diffie-Hellman Ephemeral Parameters defined in RFC 7919. module Network.TLS.Extra.FFDHE where import Crypto.PubKey.DH import Network.TLS.Crypto.DH (DHParams) -- | 2048 bits finite field Diffie-Hellman ephemeral parameters -- 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 } -- | 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 } -- | 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 } -- | 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 } -- | 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 } tls-2.1.8/Network/TLS/Handshake.hs0000644000000000000000000000173307346545000015036 0ustar0000000000000000module Network.TLS.Handshake ( handshake_, handshakeWith, handshakeClientWith, handshakeServerWith, handshakeClient, handshakeServer, ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server import Control.Monad.State.Strict 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 $ doHandshakeWith_ (ctxRoleParams ctx) ctx hs tls-2.1.8/Network/TLS/Handshake/0000755000000000000000000000000007346545000014476 5ustar0000000000000000tls-2.1.8/Network/TLS/Handshake/Certificate.hs0000644000000000000000000000407507346545000017262 0ustar0000000000000000module Network.TLS.Handshake.Certificate ( certificateRejected, badCertificate, rejectOnException, verifyLeafKeyUsage, extractCAname, ) where import Control.Exception (SomeException) import Control.Monad (unless) import Control.Monad.State.Strict import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet) import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509 -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a certificateRejected CertificateRejectRevoked = throwCore $ Error_Protocol "certificate is revoked" CertificateRevoked certificateRejected CertificateRejectExpired = throwCore $ Error_Protocol "certificate has expired" CertificateExpired certificateRejected CertificateRejectUnknownCA = throwCore $ Error_Protocol "certificate has unknown CA" UnknownCa certificateRejected CertificateRejectAbsent = throwCore $ Error_Protocol "certificate is missing" CertificateRequired certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s) CertificateUnknown badCertificate :: MonadIO m => String -> m a badCertificate msg = throwCore $ Error_Protocol msg BadCertificate rejectOnException :: SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m () verifyLeafKeyUsage _ (CertificateChain []) = return () verifyLeafKeyUsage validFlags (CertificateChain (signed : _)) = unless verified $ badCertificate $ "certificate is not allowed for any of " ++ show validFlags where cert = getCertificate signed verified = case extensionGet (certExtensions cert) of Nothing -> True -- unrestricted cert Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert tls-2.1.8/Network/TLS/Handshake/Client.hs0000644000000000000000000001374207346545000016257 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} 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 -> 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 groups <- case clientSessions cparams of [] -> return groupsSupported (_, sdata) : _ -> case sessionGroup sdata of Nothing -> return [] -- TLS 1.2 or earlier Just grp | grp `elem` groupsSupported -> return $ grp : filter (/= grp) groupsSupported | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect" handshake cparams ctx groups Nothing where groupsSupported = supportedGroups (ctxSupported ctx) -- 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 -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO () handshake cparams ctx 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 groupToSend chSentTime updateMeasure ctx incrementNbHandshakes crand <- sendClientHello cparams ctx groups mparams pskinfo -------------------------------- -- Receiving ServerHello unless async $ do (ver, hss, hrr) <- receiveServerHello cparams ctx mparams -------------------------------- -- Switching to HRR, TLS 1.2 or TLS 1.3 case ver of TLS13 | hrr -> helloRetry cparams ctx mparams ver crand $ drop 1 groups | otherwise -> do recvServerSecondFlight13 cparams ctx groupToSend sendClientSecondFlight13 cparams ctx _ | rtt0 -> throwCore $ Error_Protocol "server denied TLS 1.3 when connecting with early data" HandshakeFailure | otherwise -> do recvServerFirstFlight12 cparams ctx hss sendClientSecondFlight12 cparams ctx recvServerSecondFlight12 cparams ctx where groupToSend = listToMaybe groups receiveServerHello :: ClientParams -> Context -> Maybe (ClientRandom, Session, Version) -> IO (Version, [Handshake], Bool) receiveServerHello cparams ctx mparams = do chSentTime <- getCurrentTimeFromBase hss <- recvServerHello cparams ctx setRTT ctx chSentTime ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $ throwCore $ Error_Protocol "version changed after hello retry" IllegalParameter -- recvServerHello sets TLS13HRR according to the server random. -- For 1st server hello, getTLS13HR returns True if it is HRR and -- False otherwise. For 2nd server hello, getTLS13HR returns -- False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR return (ver, hss, hrr) ---------------------------------------------------------------- helloRetry :: ClientParams -> Context -> Maybe a -> Version -> ClientRandom -> [Group] -> IO () helloRetry cparams ctx mparams ver crand groups = do when (null groups) $ throwCore $ Error_Protocol "group is exhausted in the client side" IllegalParameter when (isJust mparams) $ throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup) | selectedGroup `elem` groups -> do usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxRecordState ctx let cparams' = cparams{clientUseEarlyData = False} runPacketFlight ctx $ sendChangeCipherSpec13 ctx clientSession <- tls13stSession <$> getTLS13State ctx handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) | 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 tls-2.1.8/Network/TLS/Handshake/Client/0000755000000000000000000000000007346545000015714 5ustar0000000000000000tls-2.1.8/Network/TLS/Handshake/Client/ClientHello.hs0000644000000000000000000003174007346545000020457 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Client.ClientHello ( sendClientHello, getPreSharedKeyInfo, ) where import Network.TLS.Cipher import Network.TLS.Compression 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.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 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 ---------------------------------------------------------------- sendClientHello :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> PreSharedKeyInfo -> IO ClientRandom sendClientHello cparams ctx groups mparams pskinfo = do crand <- generateClientHelloParams mparams sendClientHello' cparams ctx groups 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 -> [Group] -> ClientRandom -> PreSharedKeyInfo -> 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 compIds = map compressionID compressions mkClientHello exts = ClientHello ver crand compIds $ CH clientSession cipherIds exts setMyRecordLimit ctx $ limitRecordSize $ sharedLimit $ clientShared cparams extensions0 <- catMaybes <$> getExtensions let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0 extensions <- adjustExtentions extensions1 $ mkClientHello extensions1 sendPacket12 ctx $ Handshake [mkClientHello extensions] 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 compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMainSecret $ ctxSupported ctx groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations -- 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 [ {- 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 groupExt = return $ Just $ toExtensionRaw $ SupportedGroups (supportedGroups $ ctxSupported ctx) 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 $ clientShared cparams of Nothing -> return Nothing Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz sessionTicketExt = do case clientSessions cparams of (sidOrTkt, _) : _ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt _ -> return $ Just $ toExtensionRaw $ SessionTicket "" earlyDataExt | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) | otherwise = return Nothing versionExt | 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 -- FIXME keyShareExt | tls13 = case groupToSend of Nothing -> return Nothing Just grp -> do (cpri, ent) <- makeClientKeyShare ctx grp usingHState ctx $ setGroupPrivate cpri return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] | otherwise = return Nothing secureRenegExt = if supportedSecureRenegotiation $ ctxSupported ctx then do VerifyData cvd <- usingState_ ctx $ getVerifyData ClientRole return $ Just $ toExtensionRaw $ SecureRenegotiation cvd "" else return Nothing preSharedKeyExt = case pskInfo of Nothing -> return Nothing Just (identities, _, choice, obfAge) -> let zero = cZero choice pskIdentities = map (\x -> PskIdentity x obfAge) identities -- [zero] is a place holds. -- adjustExtentions will replace them. binders = replicate (length pskIdentities) zero offeredPsks = PreSharedKeyClientHello pskIdentities binders in return $ Just $ toExtensionRaw offeredPsks ---------------------------------------- adjustExtentions 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 ch h = cHash choice siz = (hashDigestSize h + 1) * length identities + 2 binder <- makePSKBinder ctx earlySecret h siz (Just 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 -- 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 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 tls-2.1.8/Network/TLS/Handshake/Client/Common.hs0000644000000000000000000003616107346545000017507 0ustar0000000000000000{-# 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] tls-2.1.8/Network/TLS/Handshake/Client/ServerHello.hs0000644000000000000000000002347107346545000020511 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Client.ServerHello ( recvServerHello, processServerHello13, ) where 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.Key import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 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 ---------------------------------------------------------------- recvServerHello :: ClientParams -> Context -> IO [Handshake] recvServerHello cparams ctx = do (sh, hss) <- recvSH processServerHello cparams ctx sh processHandshake12 ctx sh return hss 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) -> return (h, hs) _ -> 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 serverRan serverSession cipher shExts) = do let sh = ServerHello TLS12 serverRan serverSession cipher 0 shExts processServerHello cparams ctx sh 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 rver serverRan serverSession (CipherId cid) compression shExts) = do -- A server which receives a legacy_version value not equal to -- 0x0303 MUST abort the handshake with an "illegal_parameter" -- alert. when (rver /= TLS12) $ throwCore $ Error_Protocol (show rver ++ " 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 cipherAlg <- case findCipher cid clientCiphers 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 ensureNullCompression compression -- 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 shExts) $ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension let isHRR = isHelloRetryRequest serverRan usingState_ ctx $ do setTLS13HRR isHRR when isHRR $ setTLS13Cookie $ lookupAndDecode EID_Cookie MsgTServerHello shExts Nothing (\cookie@(Cookie _) -> Just cookie) setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension shExts setALPN ctx MsgTServerHello shExts ver <- usingState_ ctx getVersion when (ver == TLS12) $ do usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg let supportedVers = supportedVersions $ clientSupported cparams when (ver == TLS13) $ do -- TLS 1.3 server MUST echo the session id when (clientSession /= serverSession) $ 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 serverRan) $ throwCore $ Error_Protocol "version downgrade detected" IllegalParameter if ver == TLS13 then do -- Session is dummy in TLS 1.3. usingState_ ctx $ setSession serverSession processRecordSizeLimit cparams ctx shExts True enableMyRecordLimit ctx enablePeerRecordLimit ctx updateContext13 ctx cipherAlg else do let resumingSession = case clientSessions cparams of (_, sessionData) : _ -> if serverSession == clientSession then Just sessionData else Nothing _ -> Nothing usingState_ ctx $ do setSession serverSession setTLS12SessionResuming $ isJust resumingSession processRecordSizeLimit cparams ctx shExts False updateContext12 ctx shExts 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 -> IO () updateContext13 ctx cipherAlg = 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 $ usingHState ctx $ setHelloParameters13 cipherAlg updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO () updateContext12 ctx shExts resumingSession = do ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExts 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 = sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret logKey ctx (MainSecret mainSecret) ---------------------------------------------------------------- processRecordSizeLimit :: ClientParams -> Context -> [ExtensionRaw] -> Bool -> IO () processRecordSizeLimit cparams ctx shExts tls13 = do let mmylim = limitRecordSize $ sharedLimit $ clientShared cparams case mmylim of Nothing -> return () Just mylim -> do lookupAndDecodeAndDo EID_RecordSizeLimit MsgTClientHello shExts (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) tls-2.1.8/Network/TLS/Handshake/Client/TLS12.hs0000644000000000000000000002655107346545000017066 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Client.TLS12 ( recvServerFirstFlight12, sendClientSecondFlight12, recvServerSecondFlight12, ) where import Control.Monad.State.Strict 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 -> [Handshake] -> IO () recvServerFirstFlight12 cparams ctx hs = do resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do let st = RecvStateHandshake (expectCertificate cparams ctx) runRecvStateHS ctx st hs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) expectCertificate cparams ctx (Certificate (TLSCertificateChain 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) handshakeDone12 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 (TLSCertificateChain 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 ByteString) getCKX_RSA ctx = do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 let preMain = 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 ByteString) 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 ByteString) getCKX_ECDHE ctx = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setSupportedGroup grp ecdhePair <- generateECDHEShared 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 $ encodeGroupPublic 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] tls-2.1.8/Network/TLS/Handshake/Client/TLS13.hs0000644000000000000000000004127407346545000017066 0ustar0000000000000000{-# 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.ByteString as B import Data.IORef 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.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.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 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 -> Maybe Group -> IO () recvServerSecondFlight13 cparams ctx groupSent = do resuming <- prepareSecondFlight13 ctx groupSent runRecvHandshake13 $ do recvHandshake13 ctx $ expectEncryptedExtensions ctx unless resuming $ recvHandshake13 ctx $ expectCertRequest cparams ctx recvHandshake13hash ctx $ expectFinished cparams ctx ---------------------------------------------------------------- prepareSecondFlight13 :: Context -> Maybe Group -> IO Bool prepareSecondFlight13 ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher prepareSecondFlight13' ctx groupSent choice prepareSecondFlight13' :: Context -> Maybe 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 (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 $ 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 (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 :: 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 _ p = unexpected (show p) (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 _ (TLSCertificateChain cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify cparams ctx (CompressedCertificate13 _ (TLSCertificateChain cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate") processCertAndVerify :: MonadIO m => ClientParams -> Context -> CertificateChain -> RecvHandshake13M m () processCertAndVerify cparams ctx cc = do liftIO $ usingState_ ctx $ setServerCertificateChain cc liftIO $ doCertificate cparams ctx cc let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey recvHandshake13hash ctx $ expectCertVerify ctx pubkey ---------------------------------------------------------------- expectCertVerify :: MonadIO m => Context -> PubKey -> ByteString -> Handshake13 -> m () expectCertVerify ctx pubkey hChSc (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify") ---------------------------------------------------------------- expectFinished :: MonadIO m => ClientParams -> Context -> ByteString -> 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} sendClientSecondFlight13' :: ClientParams -> Context -> CipherChoice -> SecretTriple HandshakeSecret -> Bool -> [ExtensionRaw] -> IO () sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts = do hChSf <- transcriptHash ctx 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} handshakeDone13 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 (TLSCertificateChain 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] -- loadClientData13 _ _ _ = throwCore $ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError ---------------------------------------------------------------- ---------------------------------------------------------------- postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do processHandshake13 ctx h 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 -> Maybe Group -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx [ PendingRecvAction True expectServerHello , PendingRecvAction True (expectEncryptedExtensions ctx) , PendingRecvActionHash True expectFinishedAndSet ] where expectServerHello sh = do setRTT ctx chSentTime processServerHello13 cparams ctx sh void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do expectFinished cparams ctx h sf liftIO $ writeIORef (ctxPendingSendAction ctx) $ Just $ sendClientSecondFlight13 cparams tls-2.1.8/Network/TLS/Handshake/Common.hs0000644000000000000000000003240407346545000016265 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Common ( handshakeFailed, handleException, unexpected, newSession, handshakeDone12, ensureNullCompression, ticketOrSessionID12, -- * sending packets sendCCSandFinished, -- * receiving packets RecvState (..), runRecvState, runRecvStateHS, recvPacketHandshake, onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret, getSessionData, storePrivInfo, isSupportedGroup, checkSupportedGroup, errorToAlert, errorToAlertMessage, expectFinished, processCertificate, -- setPeerRecordSizeLimit, ) where import Control.Concurrent.MVar import Control.Exception (IOException, fromException, handle, throwIO) import Control.Monad.State.Strict import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Key import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Util import Network.TLS.X509 handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err handleException :: Context -> IO () -> IO () handleException 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) established <- ctxEstablished ctx setEstablished ctx NotEstablished handle ignoreIOErr $ do tls13 <- tls13orLater ctx 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_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) -- | 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_Warning msg _) = msg 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) 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. handshakeDone12 :: Context -> IO () handshakeDone12 ctx = do -- forget most handshake data and reset bytes counters. modifyMVar_ (ctxHandshakeState ctx) $ \case Nothing -> return Nothing Just hshake -> return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) { hstServerRandom = hstServerRandom hshake , hstMainSecret = hstMainSecret hshake , hstExtendedMainSecret = hstExtendedMainSecret hshake , hstSupportedGroup = hstSupportedGroup hshake } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. setEstablished ctx Established return () sendCCSandFinished :: Context -> Role -> IO () sendCCSandFinished ctx role = do sendPacket12 ctx ChangeCipherSpec contextFlush ctx enablePeerRecordLimit ctx verifyData <- VerifyData <$> ( usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role ) sendPacket12 ctx (Handshake [Finished verifyData]) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx data RecvState m = RecvStatePacket (Packet -> m (RecvState m)) -- CCS is not Handshake | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone recvPacketHandshake :: Context -> IO [Handshake] recvPacketHandshake ctx = do pkts <- recvPacket12 ctx case pkts of Right (Handshake l) -> return l Right x@(AppData _) -> do -- If a TLS13 server decides to reject RTT0 data, the server should -- skip records for RTT0 data up to the maximum limit. established <- ctxEstablished ctx case established of EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvPacketHandshake ctx _ -> unexpected (show x) (Just "handshake") Right 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 _ (RecvStatePacket f) hms = f (Handshake hms) onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do let finished = isFinished x unless finished $ processHandshake12 ctx x nstate <- f x when finished $ processHandshake12 ctx x onRecvStateHandshake ctx nstate xs onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing isFinished :: Handshake -> Bool isFinished Finished{} = True isFinished _ = False runRecvState :: Context -> RecvState IO -> IO () 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 -> [Handshake] -> IO () runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= 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 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 = 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 hstMainSecret ems <- usingHState ctx getExtendedMainSecret cipher <- cipherID <$> usingHState ctx getPendingCipher alpn <- usingState_ ctx getNegotiatedProtocol let compression = 0 flags = [SessionEMS | ems] case mms of Nothing -> return Nothing Just ms -> return $ Just SessionData { sessionVersion = ver , sessionCipher = cipher , sessionCompression = compression , sessionClientSNI = sni , sessionSecret = ms , sessionGroup = Nothing , sessionTicketInfo = Nothing , sessionALPN = alpn , sessionMaxEarlyDataSize = 0 , sessionFlags = flags } -- | 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 ctx cc privkey = do let c = fromCC cc pubkey = certPubKey $ getCertificate c unless (isDigitalSignaturePair (pubkey, privkey)) $ 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 checkSupportedGroup :: Context -> Group -> IO () checkSupportedGroup ctx grp = unless (isSupportedGroup ctx grp) $ let msg = "unsupported (EC)DHE group: " ++ show grp in throwCore $ Error_Protocol msg IllegalParameter isSupportedGroup :: Context -> Group -> Bool isSupportedGroup ctx grp = grp `elem` supportedGroups (ctxSupported ctx) ensureNullCompression :: MonadIO m => CompressionID -> m () ensureNullCompression compression = when (compression /= compressionID nullCompression) $ throwCore $ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter expectFinished :: Context -> Handshake -> IO (RecvState IO) expectFinished ctx (Finished verifyData) = do processFinished ctx verifyData return RecvStateDone expectFinished _ p = unexpected (show p) (Just "Handshake Finished") processFinished :: Context -> VerifyData -> IO () processFinished ctx verifyData = do (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion expected <- VerifyData <$> usingHState ctx (getHandshakeDigest ver $ invertRole cc) when (expected /= verifyData) $ decryptError "cannot verify finished" 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 tls-2.1.8/Network/TLS/Handshake/Common13.hs0000644000000000000000000005277707346545000016450 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Common13 ( makeFinished, checkFinished, makeServerKeyShare, makeClientKeyShare, fromServerKeyShare, makeCertVerify, checkCertVerify, makePSKBinder, replacePSKBinder, sendChangeCipherSpec13, handshakeDone13, makeCertRequest, createTLS13TicketInfo, ageToObfuscatedAge, isAgeValid, getAge, checkFreshness, getCurrentTimeFromBase, getSessionData13, isHashSignatureValid13, safeNonNegative32, RecvHandshake13M, runRecvHandshake13, recvHandshake13, recvHandshake13hash, CipherChoice (..), makeCipherChoice, initEarlySecret, calculateEarlySecret, calculateHandshakeSecret, calculateApplicationSecret, calculateResumptionSecret, derivePSK, checkKeyShareKeyLength, setRTT, ) where import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.UnixTime import Foreign.C.Types (CTime (..)) import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto import qualified Network.TLS.Crypto.IES as IES import Network.TLS.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.IO import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire import Control.Concurrent.MVar import Control.Monad.State.Strict ---------------------------------------------------------------- makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13 makeFinished ctx usedHash baseKey = do verifyData <- VerifyData . makeVerifyData usedHash baseKey <$> transcriptHash ctx liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData pure $ Finished13 verifyData checkFinished :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> VerifyData -> m () checkFinished ctx usedHash baseKey hashValue vd@(VerifyData 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 $ usingState_ ctx $ setVerifyDataForRecv vd makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString makeVerifyData usedHash baseKey = hmac usedHash finishedKey where hashSize = hashDigestSize usedHash finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize ---------------------------------------------------------------- makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, 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) where ecpub = IES.decodeGroupPublic 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 where espub = IES.decodeGroupPublic grp wspub ---------------------------------------------------------------- serverContextString :: ByteString serverContextString = "TLS 1.3, server CertificateVerify" clientContextString :: ByteString clientContextString = "TLS 1.3, client CertificateVerify" makeCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Handshake13 makeCertVerify ctx pub hs hashValue = do role <- liftIO $ usingState_ ctx getRole let ctxStr | role == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target checkCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool checkCertVerify ctx pub hs signature hashValue | pub `signatureCompatible13` hs = liftIO $ do role <- usingState_ ctx getRole let ctxStr | role == ClientRole = serverContextString -- opposite context | otherwise = clientContextString target = makeTarget ctxStr hashValue sigParams = signatureParams pub hs checkHashSignatureValid13 hs checkSupportedHashSignature ctx hs verifyPublic ctx sigParams target signature | otherwise = return False makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do putBytes $ B.replicate 64 32 putBytes contextString putWord8 0 putBytes hashValue sign :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Signature sign ctx pub hs target = liftIO $ do 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 rmsgs <- case mch of Just ch -> (trunc ch :) <$> usingHState ctx getHandshakeMessagesRev Nothing -> do ch : rs <- usingHState ctx getHandshakeMessagesRev return $ trunc ch : rs let hChTruncated = hash usedHash $ B.concat $ reverse rmsgs binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "") return $ makeVerifyData usedHash binderKey hChTruncated where trunc x = B.take takeLen x where totalLen = B.length x takeLen = totalLen - truncLen replacePSKBinder :: ByteString -> [ByteString] -> ByteString replacePSKBinder pskz bds = tLidentities <> binders where 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 unless sent $ loadPacket13 ctx ChangeCipherSpec13 ---------------------------------------------------------------- -- | TLS13 handshake wrap up & clean up. Contrary to @handshakeDone@, this -- does not handle session, which is managed separately for TLS 1.3. This does -- not reset byte counters because renegotiation is not allowed. And a few more -- state attributes are preserved, necessary for TLS13 handshake modes, session -- tickets and post-handshake authentication. handshakeDone13 :: Context -> IO () handshakeDone13 ctx = do -- forget most handshake data modifyMVar_ (ctxHandshakeState ctx) $ \case Nothing -> return Nothing Just hshake -> return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) { hstServerRandom = hstServerRandom hshake , hstMainSecret = hstMainSecret hshake , hstSupportedGroup = hstSupportedGroup hshake , hstHandshakeDigest = hstHandshakeDigest hshake , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake , hstTLS13RTT0Status = hstTLS13RTT0Status hshake , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake } -- forget handshake data stored in TLS state usingState_ ctx $ do setTLS13KeyShare Nothing setTLS13PreSharedKey Nothing -- mark the secure connection up and running. setEstablished ctx Established ---------------------------------------------------------------- makeCertRequest :: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13 makeCertRequest sparams ctx certReqCtx zlib = let sigAlgs = SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx signatureAlgExt = Just $ toExtensionRaw sigAlgs compCertExt | zlib = Just $ toExtensionRaw $ CompressCertificate [CCA_Zlib] | otherwise = Nothing caDns = map extractCAname $ serverCACertificates sparams 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 life ecw mrtt = do -- Left: serverSendTime -- Right: clientReceiveTime bTime <- getCurrentTimeFromBase add <- case ecw of Left ctx -> B.foldl' (*+) 0 <$> getStateRNG ctx 4 Right ad -> return ad return $ TLS13TicketInfo { lifetime = life , ageAdd = add , txrxTime = bTime , estimatedRTT = mrtt } where x *+ y = x * 256 + fromIntegral y ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second ageToObfuscatedAge age TLS13TicketInfo{..} = obfage where obfage = age + ageAdd obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second obfuscatedAgeToAge obfage TLS13TicketInfo{..} = age where age = obfage - ageAdd isAgeValid :: Second -> TLS13TicketInfo -> Bool isAgeValid age TLS13TicketInfo{..} = age <= lifetime * 1000 getAge :: TLS13TicketInfo -> IO Second getAge TLS13TicketInfo{..} = do let clientReceiveTime = txrxTime clientSendTime <- getCurrentTimeFromBase return $ fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds checkFreshness :: TLS13TicketInfo -> Second -> IO Bool checkFreshness tinfo@TLS13TicketInfo{..} obfAge = do serverReceiveTime <- getCurrentTimeFromBase 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 rtt = fromJust estimatedRTT age = obfuscatedAgeToAge obfAge tinfo expectedArrivalTime = serverSendTime + rtt + fromIntegral age isAlive = isAgeValid age tinfo getCurrentTimeFromBase :: IO Millisecond getCurrentTimeFromBase = millisecondsFromBase <$> getUnixTime millisecondsFromBase :: UnixTime -> Millisecond millisecondsFromBase (UnixTime (CTime s) us) = fromIntegral ((s - base) * 1000) + fromIntegral (us `div` 1000) where base = 1483228800 -- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT" ---------------------------------------------------------------- getSessionData13 :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData getSessionData13 ctx usedCipher tinfo maxSize psk = do ver <- usingState_ ctx getVersion malpn <- usingState_ ctx getNegotiatedProtocol 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 = [] } ---------------------------------------------------------------- -- 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) ---------------------------------------------------------------- newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a) deriving (Functor, Applicative, Monad, MonadIO) recvHandshake13 :: MonadIO m => Context -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a recvHandshake13 ctx f = getHandshake13 ctx >>= f recvHandshake13hash :: MonadIO m => Context -> (ByteString -> Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a recvHandshake13hash ctx f = do d <- transcriptHash ctx getHandshake13 ctx >>= f d getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13 getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of (h : hs) -> found h hs [] -> recvLoop where found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of Right (Handshake13 []) -> error "invalid recvPacket13 result" Right (Handshake13 (h : hs)) -> found h hs 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 (result, new) <- runStateT f [] unless (null new) $ unexpected "spurious handshake 13" Nothing return result ---------------------------------------------------------------- -- some hash/signature combinations have been deprecated in TLS13 and should -- not be used checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO () checkHashSignatureValid13 hs = unless (isHashSignatureValid13 hs) $ let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13 {- isHashSignatureValid13 (HashIntrinsic, s) = s `elem` [ SignatureRSApssRSAeSHA256 , SignatureRSApssRSAeSHA384 , SignatureRSApssRSAeSHA512 , SignatureEd25519 , SignatureEd448 , SignatureRSApsspssSHA256 , SignatureRSApsspssSHA384 , SignatureRSApsspssSHA512 ] isHashSignatureValid13 (h, SignatureECDSA) = h `elem` [HashSHA256, HashSHA384, HashSHA512] isHashSignatureValid13 _ = False -} ---------------------------------------------------------------- calculateEarlySecret :: 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 let earlySecret = case maux of Right (BaseSecret sec) -> sec Left psk -> hkdfExtract usedHash zero psk clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets return $ SecretPair (BaseSecret earlySecret) cets where usedHash = cHash choice zero = cZero choice initEarlySecret :: CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret initEarlySecret choice mpsk = BaseSecret sec where sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice zeroOrPSK = fromMaybe zero mpsk calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret -> ByteString -> 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 where usedHash = cHash choice calculateApplicationSecret :: Context -> CipherChoice -> BaseSecret HandshakeSecret -> ByteString -> IO (SecretTriple ApplicationSecret) calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do let applicationSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) zero let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf usingState_ ctx $ 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 where usedHash = cHash choice zero = cZero choice calculateResumptionSecret :: Context -> CipherChoice -> BaseSecret ApplicationSecret -> IO (BaseSecret ResumptionSecret) calculateResumptionSecret ctx choice (BaseSecret sec) = do hChCf <- transcriptHash ctx 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 = hkdfExpandLabel usedHash sec "resumption" nonce hashSize where usedHash = cHash choice hashSize = hashDigestSize usedHash ---------------------------------------------------------------- checkKeyShareKeyLength :: KeyShareEntry -> Bool checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key where grp = keyShareEntryGroup ks key = keyShareEntryKeyExchange ks keyShareKeyLength :: Group -> Int keyShareKeyLength P256 = 65 -- 32 * 2 + 1 keyShareKeyLength P384 = 97 -- 48 * 2 + 1 keyShareKeyLength P521 = 133 -- 66 * 2 + 1 keyShareKeyLength X25519 = 32 keyShareKeyLength X448 = 56 keyShareKeyLength FFDHE2048 = 256 keyShareKeyLength FFDHE3072 = 384 keyShareKeyLength FFDHE4096 = 512 keyShareKeyLength FFDHE6144 = 768 keyShareKeyLength FFDHE8192 = 1024 keyShareKeyLength _ = error "keyShareKeyLength" 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} tls-2.1.8/Network/TLS/Handshake/Control.hs0000644000000000000000000000302007346545000016445 0ustar0000000000000000module Network.TLS.Handshake.Control ( ClientState (..), ServerState (..), EarlySecretInfo (..), HandshakeSecretInfo (..), ApplicationSecretInfo (..), NegotiatedProtocol, ) where import Network.TLS.Cipher import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Types ---------------------------------------------------------------- -- | ID of the application-level protocol negotiated between client and server. -- See values listed in the . type NegotiatedProtocol = ByteString -- | Handshake information generated for traffic at 0-RTT level. data EarlySecretInfo = EarlySecretInfo Cipher (ClientTrafficSecret EarlySecret) deriving (Show) -- | Handshake information generated for traffic at handshake level. data HandshakeSecretInfo = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret) deriving (Show) -- | Handshake information generated for traffic at application level. newtype ApplicationSecretInfo = ApplicationSecretInfo (TrafficSecrets ApplicationSecret) deriving (Show) ---------------------------------------------------------------- data ClientState = SendClientHello (Maybe EarlySecretInfo) | RecvServerHello HandshakeSecretInfo | SendClientFinished [ExtensionRaw] ApplicationSecretInfo data ServerState = SendServerHello [ExtensionRaw] (Maybe EarlySecretInfo) HandshakeSecretInfo | SendServerFinished ApplicationSecretInfo tls-2.1.8/Network/TLS/Handshake/Key.hs0000644000000000000000000001550407346545000015567 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -- | 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 import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.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 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) Right econtent -> return econtent signPrivate :: Context -> Role -> SignatureParams -> ByteString -> IO ByteString signPrivate ctx _ params content = do (publicKey, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do r <- withRNG $ kxSign privateKey publicKey params content case r of Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) decryptRSA ctx econtent = do (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do let cipher = B.drop 2 econtent withRNG $ kxDecrypt privateKey cipher verifyPublic :: Context -> SignatureParams -> ByteString -> ByteString -> IO Bool verifyPublic ctx params econtent sign = do publicKey <- usingHState ctx getRemotePublicKey return $ kxVerify publicKey params econtent sign 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 generateECDHEShared :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared 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 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 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 {- 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 -- test is performed by clients or servers before verifying a remote -- Certificate Verify. checkDigitalSignatureKey :: MonadIO m => Version -> PubKey -> m () checkDigitalSignatureKey usedVersion key = do unless (isDigitalSignatureKey key) $ 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 -- | Test whether the argument is matching key pair supported for signature. -- This also accepts material for RSA encryption. This test is performed by -- servers or clients before using a credential from the local configuration. 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 getLocalPublicKey :: MonadIO m => Context -> m PubKey getLocalPublicKey ctx = usingHState ctx (fst <$> getLocalPublicPrivateKeys) -- | Test whether the public key satisfies a predicate about the elliptic curve. -- When the public key is not suitable for ECDSA, like RSA for instance, the -- predicate is not used and the result is 'True'. satisfiesEcPredicate :: (Group -> Bool) -> PubKey -> Bool satisfiesEcPredicate p (PubKeyEC ecPub) = maybe False p $ findEllipticCurveGroup ecPub satisfiesEcPredicate _ _ = True ---------------------------------------------------------------- class LogLabel a where labelAndKey :: a -> (String, ByteString) instance LogLabel MainSecret where labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key) instance LogLabel (ClientTrafficSecret EarlySecret) where labelAndKey (ClientTrafficSecret key) = ("CLIENT_EARLY_TRAFFIC_SECRET", key) instance LogLabel (ServerTrafficSecret HandshakeSecret) where labelAndKey (ServerTrafficSecret key) = ("SERVER_HANDSHAKE_TRAFFIC_SECRET", key) instance LogLabel (ClientTrafficSecret HandshakeSecret) where labelAndKey (ClientTrafficSecret key) = ("CLIENT_HANDSHAKE_TRAFFIC_SECRET", key) instance LogLabel (ServerTrafficSecret ApplicationSecret) where labelAndKey (ServerTrafficSecret key) = ("SERVER_TRAFFIC_SECRET_0", key) instance LogLabel (ClientTrafficSecret ApplicationSecret) where labelAndKey (ClientTrafficSecret key) = ("CLIENT_TRAFFIC_SECRET_0", key) -- NSS Key Log Format -- See https://developer.mozilla.org/en-US/docs/Mozilla/Projects/NSS/Key_Log_Format logKey :: LogLabel a => Context -> a -> IO () 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 where dump = init . drop 1 . showBytesHex tls-2.1.8/Network/TLS/Handshake/Process.hs0000644000000000000000000000205107346545000016446 0ustar0000000000000000-- | -- process handshake message received module Network.TLS.Handshake.Process ( processHandshake12, processHandshake13, startHandshake, ) where import Control.Concurrent.MVar import Network.TLS.Context.Internal import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Struct13 processHandshake12 :: Context -> Handshake -> IO () processHandshake12 ctx hs = do when (isHRR hs) $ usingHState ctx wrapAsMessageHash13 void $ updateHandshake12 ctx hs where isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand isHRR _ = False processHandshake13 :: Context -> Handshake13 -> IO () processHandshake13 ctx = void . updateHandshake13 ctx -- initialize a new Handshake context (initial handshake or renegotiations) startHandshake :: Context -> Version -> ClientRandom -> IO () startHandshake ctx ver crand = let hs = Just $ newEmptyHandshake ver crand in void $ swapMVar (ctxHandshakeState ctx) hs tls-2.1.8/Network/TLS/Handshake/Random.hs0000644000000000000000000000432407346545000016255 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Network.TLS.Handshake.Random ( serverRandom, clientRandom, isDowngraded, ) where import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Struct -- | Generate a server random suitable for the version selected by the server -- and its supported versions. We use an 8-byte downgrade suffix when the -- selected version is lowered because of incomplete client support, but also -- when a version downgrade has been forced with 'debugVersionForced'. This -- second part allows to test that the client implementation correctly detects -- downgrades. The suffix is not used when forcing TLS13 to a server not -- officially supporting TLS13 (this is not a downgrade scenario but only the -- 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 where genServRand suff = do pref <- getStateRNG ctx 24 return (pref `B.append` suff) -- | 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 suffix12 :: B.ByteString suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01] suffix11 :: B.ByteString suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00] clientRandom :: Context -> IO ClientRandom clientRandom ctx = ClientRandom <$> getStateRNG ctx 32 tls-2.1.8/Network/TLS/Handshake/Server.hs0000644000000000000000000000672507346545000016312 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Server ( handshakeServer, handshakeServerWith, requestCertificateServer, postHandshakeAuthServerWith, ) where import Control.Exception (bracket) import Control.Monad.State.Strict 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.IO import Network.TLS.Imports import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 -- 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] -> handshake sparams ctx ch _ -> unexpected (show hss) (Just "client hello") handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () handshakeServerWith = handshake -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter. -- This is useful when the client hello has been already poped from the recv layer to inspect the packet. -- -- When the function returns, a new handshake has been succesfully negociated. -- On any error, a HandshakeFailed exception is raised. handshake :: ServerParams -> Context -> Handshake -> IO () handshake sparams ctx clientHello = do (chosenVersion, ch) <- processClientHello sparams ctx clientHello if chosenVersion == TLS13 then do -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry. (mClientKeyShare, r0) <- processClientHello13 sparams ctx ch case mClientKeyShare of Nothing -> do sendHRR ctx r0 ch -- Don't reset ctxEstablished since 0-RTT data -- would be comming, which should be ignored. handshakeServer sparams ctx Just cliKeyShare -> do r1 <- sendServerHello13 sparams ctx cliKeyShare r0 ch recvClientSecondFlight13 sparams ctx r1 ch else do r <- processClientHello12 sparams ctx ch resumeSessionData <- sendServerHello12 sparams ctx r ch recvClientSecondFlight12 sparams ctx resumeSessionData newCertReqContext :: Context -> IO CertReqContext newCertReqContext ctx = getStateRNG ctx 32 requestCertificateServer :: ServerParams -> Context -> IO Bool requestCertificateServer sparams ctx = do tls13 <- tls13orLater ctx supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA let ok = tls13 && supportsPHA when ok $ do certReqCtx <- newCertReqContext ctx let certReq = makeCertRequest sparams ctx certReqCtx False bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do addCertRequest13 ctx certReq sendPacket13 ctx $ Handshake13 [certReq] return ok tls-2.1.8/Network/TLS/Handshake/Server/0000755000000000000000000000000007346545000015744 5ustar0000000000000000tls-2.1.8/Network/TLS/Handshake/Server/ClientHello.hs0000644000000000000000000001242707346545000020510 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ClientHello ( processClientHello, ) where import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Extension import Network.TLS.Handshake.Process import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types processClientHello :: ServerParams -> Context -> Handshake -> IO (Version, CH) processClientHello sparams ctx clientHello@(ClientHello legacyVersion cran compressions ch@CH{..}) = do 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 -- Handle Client hello hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx legacyVersion cran processHandshake12 ctx clientHello when (legacyVersion /= TLS12) $ throwCore $ Error_Protocol (show legacyVersion ++ " is not supported") ProtocolVersion -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when ( supportedFallbackScsv (ctxSupported ctx) && (CipherId 0x5600 `elem` chCiphers) && legacyVersion < 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 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 extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns) toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing serverName = lookupAndDecode EID_ServerName MsgTClientHello chExtensions Nothing extractServerName let nullComp = compressionID nullCompression case chosenVersion of TLS13 -> when (compressions /= [nullComp]) $ throwCore $ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter _ -> case find (== nullComp) compressions of Nothing -> throwCore $ Error_Protocol "compressions must include nullCompression in TLS 1.2" IllegalParameter _ -> return () maybe (return ()) (usingState_ ctx . setClientSNI) serverName return (chosenVersion, ch) processClientHello _ _ _ = throwCore $ Error_Protocol "unexpected handshake message received in handshakeServerWith" HandshakeFailure 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 tls-2.1.8/Network/TLS/Handshake/Server/ClientHello12.hs0000644000000000000000000002464507346545000020660 0ustar0000000000000000{-# 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 -> CH -> 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 -> CH -> 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 -> CH -> 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 evalutated 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 tls-2.1.8/Network/TLS/Handshake/Server/ClientHello13.hs0000644000000000000000000001120307346545000020643 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13, sendHRR, ) where 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.State import Network.TLS.Handshake.State13 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 -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context -> CH -> IO (Maybe KeyShareEntry, (Cipher, Hash, Bool)) processClientHello13 sparams ctx 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 mshare <- findKeyShare keyShares serverGroups return (mshare, (usedCipher, usedHash, rtt0)) where ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers = filter (cipherAllowedForVersion TLS13) (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 sendHRR :: Context -> (Cipher, a, b) -> CH -> IO () sendHRR ctx (usedCipher, _, _) CH{..} = do twice <- usingState_ ctx getTLS13HRR when twice $ throwCore $ Error_Protocol "Hello retry not allowed again" HandshakeFailure usingState_ ctx $ setTLS13HRR True failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher let clientGroups = lookupAndDecode EID_SupportedGroups MsgTClientHello chExtensions [] (\(SupportedGroups gs) -> gs) possibleGroups = serverGroups `intersect` clientGroups case possibleGroups of [] -> throwCore $ Error_Protocol "no group in common with the client for HRR" HandshakeFailure g : _ -> do let keyShareExt = toExtensionRaw $ KeyShareHRR g versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13 extensions = [keyShareExt, versionExt] hrr = ServerHello13 hrrRandom chSession (CipherId $ cipherID usedCipher) extensions usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest runPacketFlight ctx $ do loadPacket13 ctx $ Handshake13 [hrr] sendChangeCipherSpec13 ctx where serverGroups = supportedGroups (ctxSupported ctx) tls-2.1.8/Network/TLS/Handshake/Server/Common.hs0000644000000000000000000001673007346545000017537 0ustar0000000000000000{-# 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 (..)) 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 -> verifyLeafKeyUsage [KeyUsage_digitalSignature] 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 tls-2.1.8/Network/TLS/Handshake/Server/ServerHello12.hs0000644000000000000000000003035307346545000020701 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ServerHello12 ( sendServerHello12, ) where 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) -> CH -> 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 serverhello <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions let ff = serverhello : build [ServerHelloDone] sendPacket12 ctx $ Handshake ff contextFlush ctx Just sessionData -> do usingState_ ctx $ do setSession chSession setTLS12SessionResuming True serverhello <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession sendPacket12 ctx $ Handshake [serverhello] let mainSecret = sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole return resumeSessionData recoverSessionData :: Context -> CH -> 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 diffrent 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 (TLSCertificateChain 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) <- generateECDHE ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams usingHState ctx $ setGroupPrivate 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 Handshake makeServerHello sparams ctx usedCipher mcred chExts session = do resuming <- usingState_ ctx getTLS12SessionResuming srand <- serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams 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 let shExts = sharedHelloExtensions (serverShared sparams) ++ catMaybes [ {- 0x00 -} sniExt , {- 0x0b -} ecPointExt , {- 0x10 -} alpnExt , {- 0x17 -} emsExt , {- 0x1c -} recodeSizeLimitExt , {- 0x23 -} sessionTicketExt , {- 0xff01 -} secureRenegExt ] usingState_ ctx $ setVersion TLS12 usingHState ctx $ setServerHelloParameters TLS12 srand usedCipher nullCompression return $ ServerHello TLS12 srand session (CipherId (cipherID usedCipher)) (compressionID nullCompression) shExts negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon serverGroups chExts = lookupAndDecode EID_SupportedGroups MsgTClientHello chExts [] common where common (SupportedGroups clientGroups) = serverGroups `intersect` clientGroups tls-2.1.8/Network/TLS/Handshake/Server/ServerHello13.hs0000644000000000000000000003446707346545000020714 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ServerHello13 ( sendServerHello13, ) where import Control.Monad.State.Strict import qualified Data.ByteString as B 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.IO import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.X509 sendServerHello13 :: ServerParams -> Context -> KeyShareEntry -> (Cipher, Hash, Bool) -> CH -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret , Bool , Bool ) sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = do -- 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 $ setSupportedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter -- ALPN is used in choosePSK alpnExt <- applicationProtocol ctx chExtensions sparams (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) True let earlySecret = pairBase earlyKey clientEarlySecret = pairClient earlyKey extensions <- checkBinder earlySecret binderInfo hrr <- usingState_ ctx getTLS13HRR let authenticated = isJust binderInfo 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 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 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 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 srand <- serverRandom ctx TLS13 $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion TLS13 failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher return srand supportsPHA = lookupAndDecode EID_PostHandshakeAuth MsgTClientHello chExtensions False (\PostHandshakeAuth -> True) 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) choosePSK = lookupAndDecodeAndDo EID_PreSharedKey MsgTClientHello chExtensions (return (zero, Nothing, False)) selectPSK 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 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) rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams rtt0accept = serverEarlyDataSize sparams > 0 checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder, n, tlen)) = do binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing unless (binder == binder') $ decryptError "PSK binder validation failed" return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n] 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 srand extensions = do let keyShareExt = toExtensionRaw $ KeyShareServerHello keyShare versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13 extensions' = keyShareExt : versionExt : extensions helo = ServerHello13 srand chSession (CipherId (cipherID usedCipher)) extensions' loadPacket13 ctx $ Handshake13 [helo] 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 "" (TLSCertificateChain certChain) ess] liftIO $ usingState_ ctx $ setServerCertificateChain certChain hChSc <- transcriptHash ctx 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 let extensions = sharedHelloExtensions (serverShared sparams) ++ catMaybes [ {- 0x00 -} sniExt , {- 0x0a -} groupExt , {- 0x10 -} alpnExt , {- 0x1c -} recodeSizeLimitExt , {- 0x2a -} earlyDataExt ] extensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions'] dhModes = lookupAndDecode EID_PskKeyExchangeModes MsgTClientHello chExtensions [] (\(PskKeyExchangeModes ms) -> ms) hashSize = hashDigestSize usedHash zero = B.replicate hashSize 0 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 tls-2.1.8/Network/TLS/Handshake/Server/TLS12.hs0000644000000000000000000002102007346545000017100 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Server.TLS12 ( recvClientSecondFlight12, ) where import Control.Monad.State.Strict (gets) 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 handshakeDone12 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 (TLSCertificateChain 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 preMain of Left _ -> usingHState ctx $ setMainSecretFromPre rver role random Right (ver, _) | ver /= expectedVer -> usingHState ctx $ setMainSecretFromPre rver role 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 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 preMain -> do rver <- usingState_ ctx getVersion role <- usingState_ ctx getRole mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain logKey ctx (MainSecret mainSecret) Nothing -> throwCore $ Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter ---------------------------------------------------------------- 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 tls-2.1.8/Network/TLS/Handshake/Server/TLS13.hs0000644000000000000000000002413107346545000017107 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.TLS13 ( recvClientSecondFlight13, postHandshakeAuthServerWith, ) where import Control.Monad.State.Strict import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Extension import Network.TLS.Handshake.Common hiding (expectFinished) import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key import Network.TLS.Handshake.Process import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.X509 recvClientSecondFlight13 :: ServerParams -> Context -> ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret , Bool , Bool ) -> CH -> 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 recvHandshake13 ctx $ expectCertificate sparams ctx recvHandshake13hash ctx (expectCertVerify sparams ctx) recvHandshake13hash ctx 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 expectFinished' ensureRecvComplete ctx expectFinished :: MonadIO m => ServerParams -> Context -> [ExtensionRaw] -> SecretTriple ApplicationSecret -> ClientTrafficSecret HandshakeSecret -> Word64 -> ByteString -> 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 handshakeDone13 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 () expectCertificate sparams ctx (Certificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs expectCertificate sparams ctx (CompressedCertificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx 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 <- 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 = fromMaybe sessionId mticket return (identity, ageAdd tinfo) createNewSessionTicket life add nonce identity maxSize = NewSessionTicket13 life add nonce identity extensions where earlyDataExt = toExtensionRaw $ EarlyDataIndication $ Just $ fromIntegral maxSize extensions = [earlyDataExt] adjustLifetime i | i < 0 = 0 | i > 604800 = 604800 | otherwise = fromIntegral i expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () expectCertVerify sparams ctx 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" postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO () postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx (TLSCertificateChain certs) _ext) = processHandshakeAuthServerWith sparams ctx certCtx certs h postHandshakeAuthServerWith sparams ctx h@(CompressedCertificate13 certCtx (TLSCertificateChain certs) _ext) = processHandshakeAuthServerWith sparams ctx certCtx certs h postHandshakeAuthServerWith _ _ _ = throwCore $ Error_Protocol "unexpected handshake message received in postHandshakeAuthServerWith" UnexpectedMessage processHandshakeAuthServerWith :: ServerParams -> Context -> CertReqContext -> CertificateChain -> Handshake13 -> IO () processHandshakeAuthServerWith sparams ctx certCtx certs h = do mCertReq <- getCertRequest13 ctx certCtx when (isNothing mCertReq) $ throwCore $ Error_Protocol "unknown certificate request context" DecodeError let certReq = fromJust mCertReq -- fixme checking _ext clientCertificate sparams ctx certs baseHState <- saveHState ctx processHandshake13 ctx certReq processHandshake13 ctx h (usedHash, _, level, applicationSecretN) <- getRxRecordState 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 setPendingRecvActions ctx [PendingRecvActionHash False expectFinished'] else setPendingRecvActions ctx [ PendingRecvActionHash False (expectCertVerify sparams ctx) , PendingRecvActionHash False expectFinished' ] tls-2.1.8/Network/TLS/Handshake/Signature.hs0000644000000000000000000003062107346545000016775 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} 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.Crypto import Network.TLS.Handshake.Key import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Packet ( encodeSignedDHParams, encodeSignedECDHParams, ) import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct import Network.TLS.X509 decryptError :: MonadIO m => String -> m a decryptError msg = throwCore $ Error_Protocol msg DecryptError -- | Check that the key is compatible with a list of 'CertificateType' values. -- Ed25519 and Ed448 have no assigned code point and are checked with extension -- "signature_algorithms" only. certificateCompatible :: PubKey -> [CertificateType] -> Bool certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes certificateCompatible (PubKeyDSA _) cTypes = CertificateType_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 _) (_, 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 signatureCompatible13 :: PubKey -> HashAndSignatureAlgorithm -> Bool signatureCompatible13 (PubKeyEC ecPub) (h, SignatureECDSA) = maybe False (\g -> findEllipticCurveGroup ecPub == Just g) (hashCurve h) where hashCurve HashSHA256 = Just P256 hashCurve HashSHA384 = Just P384 hashCurve HashSHA512 = Just P521 hashCurve _ = Nothing signatureCompatible13 pub hs = signatureCompatible pub hs -- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'. -- Perhaps this needs to take supported groups into account, so that, for -- example, if we don't support any shared ECDSA groups with the server, we -- return 'Nothing' rather than 'CertificateType_ECDSA_Sign'. -- -- Therefore, this interface is preliminary. It gets us moving in the right -- direction. The interplay between all the various TLS extensions and -- certificate selection is rather complex. -- -- The goal is to ensure that the client certificate request callback only sees -- 'CertificateType' values that are supported by the library and also -- compatible with the server signature algorithms extension. -- -- Since we don't yet support ECDSA private keys, the caller will use -- 'lastSupportedCertificateType' to filter those out for now, leaving just -- @RSA@ as the only supported client certificate algorithm for TLS 1.3. -- -- FIXME: Add RSA_PSS_PSS signatures when supported. hashSigToCertType :: HashAndSignatureAlgorithm -> Maybe CertificateType -- hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign -- hashSigToCertType (_, SignatureDSA) = Just CertificateType_DSA_Sign -- hashSigToCertType (_, 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 _ = Nothing 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 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 type CertVerifyData = (SignatureParams, ByteString) -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as -- 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) prepareCertificateVerifySignatureData :: Context -> Version -> PubKey -> HashAndSignatureAlgorithm -- TLS12 only -> ByteString -> IO CertVerifyData prepareCertificateVerifySignatureData _ctx _usedVersion pubKey hashSigAlg msgs = return (signatureParams pubKey hashSigAlg, msgs) signatureParams :: PubKey -> HashAndSignatureAlgorithm -> SignatureParams signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 (HashSHA1, SignatureRSA) -> RSAParams SHA1 RSApkcs1 (HashIntrinsic, SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss (HashIntrinsic, SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss (HashIntrinsic, SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss (hsh, SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) (_, sigAlg) -> error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of (HashSHA1, SignatureDSA) -> DSAParams (_, SignatureDSA) -> error "invalid DSA hash choice, only SHA1 allowed" (_, sigAlg) -> error ("signature algorithm is incompatible with DSA: " ++ show sigAlg) signatureParams (PubKeyEC _) hashSigAlg = case hashSigAlg of (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 (HashSHA1, SignatureECDSA) -> ECDSAParams SHA1 (hsh, SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) (_, sigAlg) -> error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) signatureParams (PubKeyEd25519 _) hashSigAlg = case hashSigAlg of (HashIntrinsic, SignatureEd25519) -> Ed25519Params (hsh, SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh) (_, sigAlg) -> error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) signatureParams (PubKeyEd448 _) hashSigAlg = case hashSigAlg of (HashIntrinsic, SignatureEd448) -> Ed448Params (hsh, SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) (_, sigAlg) -> error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") signatureCreateWithCertVerifyData :: Context -> HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do 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, 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 ctx (DigitallySigned hs bs) (sigParam, toVerify) = do checkSupportedHashSignature ctx hs verifyPublic ctx sigParam toVerify bs digitallySignParams :: Context -> ByteString -> PubKey -> HashAndSignatureAlgorithm -> IO DigitallySigned digitallySignParams ctx signatureData pubKey hashSigAlg = let sigParam = signatureParams pubKey hashSigAlg in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData) digitallySignDHParams :: Context -> ServerDHParams -> PubKey -> HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned digitallySignDHParams ctx serverParams pubKey mhash = do dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams digitallySignParams ctx dhParamsData pubKey mhash digitallySignECDHParams :: Context -> ServerECDHParams -> PubKey -> HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned digitallySignECDHParams ctx serverParams pubKey mhash = do ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams digitallySignParams ctx ecdhParamsData pubKey mhash 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 ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedECDHParams dhparams signatureVerify ctx signature pubKey expectedData withClientAndServerRandom :: Context -> (ClientRandom -> ServerRandom -> b) -> IO b withClientAndServerRandom ctx f = do (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 -> 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 tls-2.1.8/Network/TLS/Handshake/State.hs0000644000000000000000000005167507346545000016130 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.State ( HandshakeState (..), HandshakeDigest (..), HandshakeMode13 (..), RTT0Status (..), CertReqCBdata, HandshakeM, newEmptyHandshake, runHandshake, -- * key accessors 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, -- * digest accessors addHandshakeMessage, updateHandshakeDigest, getHandshakeMessages, getHandshakeMessagesRev, getHandshakeDigest, foldHandshakeDigest, -- * main secret setMainSecret, setMainSecretFromPre, -- * misc accessor getPendingCipher, setServerHelloParameters, setExtendedMainSecret, getExtendedMainSecret, setSupportedGroup, getSupportedGroup, setTLS13HandshakeMode, getTLS13HandshakeMode, setTLS13RTT0Status, getTLS13RTT0Status, setTLS13EarlySecret, getTLS13EarlySecret, setTLS13ResumptionSecret, getTLS13ResumptionSecret, setTLS13CertComp, getTLS13CertComp, setCCS13Sent, getCCS13Sent, setCCS13Recv, getCCS13Recv, ) where import Control.Monad.State.Strict import Data.ByteArray (ByteArrayAccess) import Data.X509 (CertificateChain) import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Crypto import Network.TLS.Imports 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) data HandshakeDigest = HandshakeMessages [ByteString] | HandshakeDigestContext HashCtx deriving (Show) data HandshakeState = HandshakeState { hstClientVersion :: Version , hstClientRandom :: ClientRandom , hstServerRandom :: Maybe ServerRandom , hstMainSecret :: 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 , hstExtendedMainSecret :: Bool , hstSupportedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: RTT0Status , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool , hstCCS13Recv :: 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. -- -- 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] ) 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 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 , hstMainSecret = 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 , hstExtendedMainSecret = False , hstSupportedGroup = Nothing , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None , hstTLS13EarlySecret = Nothing , hstTLS13ResumptionSecret = Nothing , hstTLS13CertComp = False , hstCCS13Sent = False , hstCCS13Recv = 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} setPublicPrivateKeys :: (PubKey, PrivKey) -> HandshakeM () setPublicPrivateKeys keys = modify (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)}) where setKeys hks = hks{hksLocalPublicPrivateKeys = Just keys} getRemotePublicKey :: HandshakeM PubKey getRemotePublicKey = fromJust <$> gets (hksRemotePublicKey . hstKeyState) getLocalPublicPrivateKeys :: HandshakeM (PubKey, PrivKey) getLocalPublicPrivateKeys = fromJust <$> gets (hksLocalPublicPrivateKeys . hstKeyState) setServerDHParams :: ServerDHParams -> HandshakeM () setServerDHParams shp = modify (\hst -> hst{hstServerDHParams = Just shp}) getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust <$> gets hstServerDHParams setServerECDHParams :: ServerECDHParams -> HandshakeM () setServerECDHParams shp = modify (\hst -> hst{hstServerECDHParams = Just shp}) getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust <$> gets hstServerECDHParams setDHPrivate :: DHPrivate -> HandshakeM () setDHPrivate shp = modify (\hst -> hst{hstDHPrivate = Just shp}) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate getGroupPrivate :: HandshakeM GroupPrivate getGroupPrivate = fromJust <$> gets hstGroupPrivate setGroupPrivate :: GroupPrivate -> HandshakeM () setGroupPrivate shp = modify (\hst -> hst{hstGroupPrivate = Just shp}) setExtendedMainSecret :: Bool -> HandshakeM () setExtendedMainSecret b = modify (\hst -> hst{hstExtendedMainSecret = b}) getExtendedMainSecret :: HandshakeM Bool getExtendedMainSecret = gets hstExtendedMainSecret setSupportedGroup :: Group -> HandshakeM () setSupportedGroup g = modify (\hst -> hst{hstSupportedGroup = Just g}) 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. 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) setTLS13HandshakeMode :: HandshakeMode13 -> HandshakeM () setTLS13HandshakeMode s = modify (\hst -> hst{hstTLS13HandshakeMode = s}) getTLS13HandshakeMode :: HandshakeM HandshakeMode13 getTLS13HandshakeMode = gets hstTLS13HandshakeMode data RTT0Status = RTT0None | RTT0Sent | RTT0Accepted | RTT0Rejected deriving (Show, Eq) setTLS13RTT0Status :: RTT0Status -> HandshakeM () 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}) getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) getTLS13EarlySecret = gets hstTLS13EarlySecret setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM () 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}) 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}) getCertReqSent :: HandshakeM Bool getCertReqSent = gets hstCertReqSent setClientCertSent :: Bool -> HandshakeM () setClientCertSent b = modify (\hst -> hst{hstClientCertSent = b}) getClientCertSent :: HandshakeM Bool getClientCertSent = gets hstClientCertSent setClientCertChain :: CertificateChain -> HandshakeM () 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} getCertReqToken :: HandshakeM (Maybe ByteString) getCertReqToken = gets hstCertReqToken -- setCertReqCBdata :: Maybe CertReqCBdata -> HandshakeM () 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} getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm]) getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert -- getPendingCipher :: HandshakeM Cipher getPendingCipher = fromJust <$> gets hstPendingCipher addHandshakeMessage :: ByteString -> HandshakeM () addHandshakeMessage content = modify $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) getHandshakeMessagesRev :: HandshakeM [ByteString] getHandshakeMessagesRev = gets hstHandshakeMessages updateHandshakeDigest :: ByteString -> HandshakeM () updateHandshakeDigest content = modify $ \hs -> hs { hstHandshakeDigest = case hstHandshakeDigest hs of HandshakeMessages bytes -> HandshakeMessages (content : bytes) HandshakeDigestContext hashCtx -> HandshakeDigestContext $ hashUpdate hashCtx content } -- | Compress the whole transcript with the specified function. Function @f@ -- takes the handshake digest as input and returns an encoded handshake message -- to replace the transcript with. foldHandshakeDigest :: Hash -> (ByteString -> ByteString) -> HandshakeM () foldHandshakeDigest hashAlg f = modify $ \hs -> case hstHandshakeDigest hs of HandshakeMessages bytes -> let hashCtx = foldl hashUpdate (hashInit hashAlg) $ reverse bytes folded = f (hashFinal hashCtx) in hs { hstHandshakeDigest = HandshakeMessages [folded] , hstHandshakeMessages = [folded] } HandshakeDigestContext hashCtx -> let folded = f (hashFinal hashCtx) hashCtx' = hashUpdate (hashInit hashAlg) folded in hs { hstHandshakeDigest = HandshakeDigestContext hashCtx' , hstHandshakeMessages = [folded] } getSessionHash :: HandshakeM ByteString getSessionHash = gets $ \hst -> case hstHandshakeDigest hst of HandshakeDigestContext hashCtx -> hashFinal hashCtx HandshakeMessages _ -> error "un-initialized session hash" getHandshakeDigest :: Version -> Role -> HandshakeM ByteString getHandshakeDigest ver role = gets gen where gen hst = case hstHandshakeDigest hst of HandshakeDigestContext hashCtx -> let msecret = fromJust $ hstMainSecret hst cipher = fromJust $ hstPendingCipher hst in generateFinished ver cipher msecret hashCtx HandshakeMessages _ -> error "un-initialized handshake digest" generateFinished | role == ClientRole = generateClientFinished | otherwise = generateServerFinished -- | Generate the main secret from the pre-main secret. setMainSecretFromPre :: ByteArrayAccess preMain => Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side -> preMain -- ^ the pre-main secret -> HandshakeM ByteString 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 -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. setMainSecret :: Version -> Role -> ByteString -> HandshakeM () setMainSecret ver role mainSecret = modify $ \hst -> 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 mainSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust $ 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 $ hstServerRandom hst) mainSecret keyblockSize (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 = cWriteIV , cstMacSecret = cMACSecret } cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey , cstIV = sWriteIV , cstMacSecret = sMACSecret } msClient = MacState{msSequence = 0} msServer = MacState{msSequence = 0} 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 } orOnServer f g = if cc == ClientRole then f else g setServerHelloParameters :: Version -- ^ chosen version -> ServerRandom -> Cipher -> Compression -> HandshakeM () setServerHelloParameters ver sran cipher compression = do modify $ \hst -> hst { hstServerRandom = Just sran , hstPendingCipher = Just cipher , hstPendingCompression = compression , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst } where hashAlg = getHash ver cipher updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest" -- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getHash :: Version -> Cipher -> Hash getHash ver ciph | ver < TLS12 = SHA1_MD5 | maybe True (< TLS12) (cipherMinVer ciph) = SHA256 | otherwise = cipherHash ciph tls-2.1.8/Network/TLS/Handshake/State13.hs0000644000000000000000000001462507346545000016266 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.State13 ( CryptLevel ( CryptEarlySecret, CryptHandshakeSecret, CryptApplicationSecret ), TrafficSecret, getTxRecordState, getRxRecordState, setTxRecordState, setRxRecordState, getTxLevel, getRxLevel, clearTxRecordState, clearRxRecordState, setHelloParameters13, transcriptHash, wrapAsMessageHash13, PendingRecvAction (..), setPendingRecvActions, popPendingRecvAction, ) where import Control.Concurrent.MVar import Control.Monad.State import qualified Data.ByteString as B import Data.IORef import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.KeySchedule (hkdfExpandLabel) import Network.TLS.Record.State import Network.TLS.Struct import Network.TLS.Types getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) getTxRecordState ctx = getXState ctx ctxTxRecordState getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) getRxRecordState ctx = getXState ctx ctxRxRecordState getXState :: Context -> (Context -> MVar RecordState) -> IO (Hash, Cipher, CryptLevel, ByteString) getXState ctx func = do tx <- readMVar (func ctx) 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) instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s) instance HasCryptLevel a => TrafficSecret (ClientTrafficSecret a) where fromTrafficSecret prx@(ClientTrafficSecret s) = (getCryptLevel prx, s) instance HasCryptLevel a => TrafficSecret (ServerTrafficSecret a) where fromTrafficSecret prx@(ServerTrafficSecret s) = (getCryptLevel prx, s) setTxRecordState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () setTxRecordState = setXState ctxTxRecordState BulkEncrypt 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 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' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt) where bulk = cipherBulk cipher keySize = bulkKeySize 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 } clearTxRecordState :: Context -> IO () clearTxRecordState = clearXState ctxTxRecordState 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 <$> getHState ctx case hstHandshakeDigest hst of HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx HandshakeMessages _ -> error "un-initialized handshake digest" setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx) 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 tls-2.1.8/Network/TLS/HashAndSignature.hs0000644000000000000000000001710107346545000016334 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# 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) instance {-# OVERLAPS #-} Show (HashAlgorithm, SignatureAlgorithm) where show (HashIntrinsic, s) = show s show (h, s) = show h ++ "-" ++ show s {- 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 -} tls-2.1.8/Network/TLS/Hooks.hs0000644000000000000000000000320707346545000014231 0ustar0000000000000000module Network.TLS.Hooks ( Logging (..), defaultLogging, Hooks (..), defaultHooks, ) where import qualified Data.ByteString as B import Data.Default (Default (def)) import Network.TLS.Struct (Handshake, Header) import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain) -- | Hooks for logging -- -- This is called when sending and receiving packets and IO data Logging = Logging { loggingPacketSent :: String -> IO () , loggingPacketRecv :: String -> IO () , loggingIOSent :: B.ByteString -> IO () , loggingIORecv :: Header -> B.ByteString -> IO () } defaultLogging :: Logging defaultLogging = Logging { loggingPacketSent = \_ -> return () , loggingPacketRecv = \_ -> return () , loggingIOSent = \_ -> return () , loggingIORecv = \_ _ -> return () } instance Default Logging where def = defaultLogging -- | A collection of hooks actions. data Hooks = Hooks { 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 () -- ^ 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 } instance Default Hooks where def = defaultHooks tls-2.1.8/Network/TLS/IO.hs0000644000000000000000000002207607346545000013462 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} module Network.TLS.IO ( sendPacket12, sendPacket13, recvPacket12, recvPacket13, -- isRecvComplete, checkValid, -- * Grouping multiple packets in the same flight PacketFlightM, runPacketFlight, loadPacket13, ) where import Control.Exception (finally, throwIO) import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as B import Data.IORef import 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.Parameters import Network.TLS.Record import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 ---------------------------------------------------------------- -- | Send one packet to the context sendPacket12 :: Context -> Packet -> IO () sendPacket12 ctx@Context{ctxRecordLayer = recordLayer} pkt = do -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed -- by an attacker. Hence, an empty packet is sent before a normal data packet, to -- prevent guessability. when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $ writePacketBytes12 ctx recordLayer (AppData B.empty) >>= recordSendBytes recordLayer ctx writePacketBytes12 ctx recordLayer pkt >>= recordSendBytes recordLayer ctx where isNonNullAppData (AppData b) = not $ B.null b isNonNullAppData _ = False writePacketBytes12 :: Monoid bytes => Context -> RecordLayer bytes -> Packet -> IO bytes writePacketBytes12 ctx recordLayer pkt = do withLog ctx $ \logging -> loggingPacketSent logging (show 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 ctx 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 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) -> do pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> Right . Handshake <$> mapM (hookRecvHandshake hooks) hss logPacket ctx $ show pkt return pktRecv' Right pkt -> do logPacket ctx $ show pkt return pktRecv Left err -> do logPacket ctx $ show err return pktRecv isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool isEmptyHandshake (Right (Handshake [])) = True isEmptyHandshake _ = 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} = 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) -> do pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss 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 ---------------------------------------------------------------- isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do cont <- gets stHandshakeRecordCont cont13 <- gets stHandshakeRecordCont13 return $ isNothing cont && isNothing cont13 checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx when (established == NotEstablished) $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx when eofed $ throwIO $ PostHandshake Error_EOF ---------------------------------------------------------------- type Builder b = [b] -> [b] -- | State monad used to group several packets together and send them on wire as -- single flight. When packets are loaded in the monad, they are logged -- 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) deriving (Functor, Applicative, Monad, MonadFail, MonadIO) runPacketFlight :: Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a runPacketFlight ctx@Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do ref <- newIORef id runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref 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 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 :)) tls-2.1.8/Network/TLS/IO/0000755000000000000000000000000007346545000013117 5ustar0000000000000000tls-2.1.8/Network/TLS/IO/Decode.hs0000644000000000000000000001027107346545000014637 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.TLS.IO.Decode ( decodePacket12, decodePacket13, ) where import Control.Concurrent.MVar import Control.Monad.State.Strict import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.ErrT import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Record import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Util import Network.TLS.Wire 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 <- 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 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 <- 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 decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") tls-2.1.8/Network/TLS/IO/Encode.hs0000644000000000000000000001036707346545000014657 0ustar0000000000000000module Network.TLS.IO.Encode ( encodePacket12, encodePacket13, updateHandshake12, updateHandshake13, ) where import Control.Concurrent.MVar import Control.Monad.State.Strict import qualified Data.ByteString as B import Data.IORef import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.Record import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types (Role (..)) import Network.TLS.Util -- | encodePacket transform a packet into marshalled data related to current state -- and updating state on the go encodePacket12 :: Monoid bytes => Context -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes) encodePacket12 ctx recordLayer pkt = do (ver, _) <- decideRecordVersion ctx let pt = packetType pkt mkRecord bs = Record pt ver (fragmentPlaintext bs) 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 (updateHandshake12 ctx) hss packetToFragments12 _ _ (Alert a) = return [encodeAlerts a] packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments12 _ _ (AppData x) = return [x] switchTxEncryption :: Context -> IO () switchTxEncryption ctx = do tx <- usingHState ctx (fromJust <$> gets hstPendingTxState) (ver, role) <- usingState_ ctx $ do v <- getVersion r <- getRole return (v, r) liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx) -- set empty packet counter measure if condition are met when ( ver <= TLS10 && role == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx) ) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) updateHandshake12 :: Context -> Handshake -> IO ByteString updateHandshake12 ctx hs = do usingHState ctx $ do when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded return encoded where encoded = encodeHandshake hs ---------------------------------------------------------------- encodePacket13 :: Monoid bytes => Context -> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes) encodePacket13 ctx recordLayer pkt = do let pt = contentType pkt mkRecord bs = Record pt TLS12 (fragmentPlaintext bs) 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 (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 tls-2.1.8/Network/TLS/Imports.hs0000644000000000000000000000143407346545000014603 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module Network.TLS.Imports ( -- generic exports 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 import Data.Functor import Control.Applicative import Control.Monad import Data.Bits import Data.List import Data.Maybe import Data.Ord import Data.Semigroup import Data.Word import Data.ByteArray.Encoding as B import qualified Prelude as P showBytesHex :: ByteString -> P.String showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString) tls-2.1.8/Network/TLS/Internal.hs0000644000000000000000000000175607346545000014731 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} 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.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire import Network.TLS.X509 hiding (Certificate) ---------------------------------------------------------------- makeCipherShowPretty :: IO () makeCipherShowPretty = writeIORef globalCipherDict ciphersuite_all tls-2.1.8/Network/TLS/KeySchedule.hs0000644000000000000000000000433307346545000015354 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.TLS.KeySchedule ( hkdfExtract, hkdfExpandLabel, deriveSecret, ) where import qualified Crypto.Hash as H import Crypto.KDF.HKDF import Data.ByteArray (convert) import qualified Data.ByteString as BS import Network.TLS.Crypto import Network.TLS.Imports 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 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" ---------------------------------------------------------------- deriveSecret :: Hash -> ByteString -> ByteString -> ByteString -> ByteString deriveSecret h secret label hashedMsgs = hkdfExpandLabel h secret label hashedMsgs outlen where outlen = hashDigestSize h ---------------------------------------------------------------- -- | @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 h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do putWord16 $ fromIntegral outlen 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' 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 expand' _ _ _ _ = error "expand'" ---------------------------------------------------------------- tls-2.1.8/Network/TLS/MAC.hs0000644000000000000000000000471407346545000013552 0ustar0000000000000000module Network.TLS.MAC ( macSSL, hmac, prf_MD5, prf_SHA1, prf_SHA256, prf_TLS, prf_MD5SHA1, ) where import qualified Data.ByteArray as B (xor) import qualified Data.ByteString as B import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types type HMAC = ByteString -> ByteString -> ByteString macSSL :: Hash -> HMAC macSSL alg secret msg = f $ B.concat [ secret , B.replicate padLen 0x5c , f $ B.concat [secret, B.replicate padLen 0x36, msg] ] where padLen = case alg of MD5 -> 48 SHA1 -> 40 _ -> 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' 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 hmacIter :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] 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) prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len prf_MD5 :: ByteString -> ByteString -> Int -> ByteString prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString 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 prf_SHA256 :: ByteString -> ByteString -> Int -> ByteString prf_SHA256 secret seed len = B.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 _ halg secret seed len = B.concat $ hmacIter (hmac halg) secret seed seed len tls-2.1.8/Network/TLS/Measurement.hs0000644000000000000000000000231607346545000015433 0ustar0000000000000000module 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) newMeasurement :: Measurement newMeasurement = Measurement { nbHandshakes = 0 , bytesReceived = 0 , bytesSent = 0 } addBytesReceived :: Int -> Measurement -> Measurement addBytesReceived sz measure = measure{bytesReceived = bytesReceived measure + fromIntegral sz} addBytesSent :: Int -> Measurement -> Measurement addBytesSent sz measure = measure{bytesSent = bytesSent measure + fromIntegral sz} resetBytesCounters :: Measurement -> Measurement resetBytesCounters measure = measure{bytesReceived = 0, bytesSent = 0} incrementNbHandshakes :: Measurement -> Measurement incrementNbHandshakes measure = measure{nbHandshakes = nbHandshakes measure + 1} tls-2.1.8/Network/TLS/Packet.hs0000644000000000000000000005325307346545000014363 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# 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 (..), -- * marshall functions for header messages decodeHeader, encodeHeader, -- * marshall functions for alert messages decodeAlert, decodeAlerts, encodeAlerts, -- * marshall functions for handshake messages decodeHandshakeRecord, decodeHandshake, encodeHandshake, encodeCertificate, -- * marshall functions for change cipher spec message decodeChangeCipherSpec, encodeChangeCipherSpec, decodePreMainSecret, encodePreMainSecret, encodeSignedDHParams, encodeSignedECDHParams, decodeReallyServerKeyXchgAlgorithmData, -- * generate things for packet content generateMainSecret, generateExtendedMainSecret, generateKeyBlock, generateClientFinished, generateServerFinished, -- * for extensions parsing getSignatureHashAlgorithm, putSignatureHashAlgorithm, getBinaryVersion, putBinaryVersion, getClientRandom32, putClientRandom32, getServerRandom32, putServerRandom32, getExtensions, putExtension, getSession, putSession, putDNames, getDNames, getHandshakeType, ) where import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as B (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.Struct import Network.TLS.Types import Network.TLS.Util.ASN1 import Network.TLS.Wire ---------------------------------------------------------------- -- Header data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type } deriving (Show, Eq) -- marshall helpers getBinaryVersion :: Get Version getBinaryVersion = Version <$> getWord16 putBinaryVersion :: Version -> Put putBinaryVersion (Version ver) = putWord16 ver getHeaderType :: Get ProtocolType getHeaderType = ProtocolType <$> getWord8 putHeaderType :: ProtocolType -> Put putHeaderType (ProtocolType pt) = putWord8 pt getHandshakeType :: Get HandshakeType getHandshakeType = HandshakeType <$> getWord8 -- decode and encode headers decodeHeader :: ByteString -> Either TLSError Header 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 ------------------------------------------------------------ -- CCS decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do x <- getWord8 when (x /= 1) $ fail "unknown change cipher spec content" len <- remaining when (len /= 0) $ fail "the length of CSS must be 1" encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) ---------------------------------------------------------------- -- Alert decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do al <- AlertLevel <$> getWord8 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 encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString encodeAlerts l = runPut $ mapM_ encodeAlert l where encodeAlert (al, ad) = putWord8 (fromAlertLevel al) >> putWord8 (fromAlertDescription ad) ---------------------------------------------------------------- -- decode HANDSHAKE decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType content <- getOpaque24 return (ty, content) {- 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_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 <- getBinaryVersion random <- getClientRandom32 session <- getSession ciphers <- map CipherId <$> getWords16 compressions <- getWords8 r <- remaining exts <- if r > 0 then getWord16 >>= getExtensions . fromIntegral else return [] r1 <- remaining when (r1 /= 0) $ fail "Client hello" let ch = CH session ciphers exts return $ ClientHello ver random compressions ch decodeServerHello :: Get Handshake decodeServerHello = do ver <- getBinaryVersion random <- getServerRandom32 session <- getSession cipherid <- CipherId <$> getWord16 compressionid <- getWord8 r <- remaining exts <- if r > 0 then getWord16 >>= getExtensions . fromIntegral else return [] return $ ServerHello ver random session cipherid compressionid exts decodeNewSessionTicket :: Get Handshake decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16 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 $ Certificate $ TLSCertificateChain cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) ---- decodeServerKeyXchg :: CurrentParams -> Get Handshake decodeServerKeyXchg cp = case cParamsKeyXchgType cp of 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 -- We don't support ECDH_Anon at this moment -- decodeServerKeyXchg_ECDH :: Get ServerECDHParams decodeServerKeyXchg_RSA :: Get ServerRSAParams decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus <*> getInteger16 -- exponent ---- decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest _cp = do certTypes <- map CertificateType <$> getWords8 sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms CertRequest certTypes sigHashAlgs <$> getDNames where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) ---- decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone decodeCertVerify :: CurrentParams -> Get Handshake decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp) decodeClientKeyXchg :: CurrentParams -> Get Handshake decodeClientKeyXchg cp = -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of 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 decodeFinished :: Get Handshake decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes) ---------------------------------------------------------------- -- encode HANDSHAKE 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] encodeHandshakeHeader :: HandshakeType -> Int -> Put encodeHandshakeHeader ty len = putWord8 (fromHandshakeType ty) >> putWord24 len encodeHandshake' :: Handshake -> ByteString encodeHandshake' HelloRequest = "" encodeHandshake' (ClientHello version random compressionIDs CH{..}) = runPut $ do putBinaryVersion version putClientRandom32 random putSession chSession putWords16 $ map fromCipherId chCiphers putWords8 compressionIDs putExtensions chExtensions return () encodeHandshake' (ServerHello version random session cipherid compressionID exts) = runPut $ do putBinaryVersion version putServerRandom32 random putSession session putWord16 $ fromCipherId cipherid putWord8 compressionID putExtensions exts return () encodeHandshake' (NewSessionTicket life ticket) = runPut $ do putWord32 life putOpaque16 ticket encodeHandshake' (Certificate (TLSCertificateChain cc)) = encodeCertificate cc encodeHandshake' (ServerKeyXchg skg) = runPut $ case skg of 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_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 ("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 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 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 getServerRandom32 :: Get ServerRandom getServerRandom32 = ServerRandom <$> getRandom32 getClientRandom32 :: Get ClientRandom getClientRandom32 = ClientRandom <$> getRandom32 putRandom32 :: ByteString -> Put putRandom32 = putBytes putClientRandom32 :: ClientRandom -> Put putClientRandom32 (ClientRandom r) = putRandom32 r putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r ------------------------------------------------------------ getSession :: Get Session getSession = do len8 <- getWord8 case fromIntegral len8 of 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 (Just s)) = putOpaque8 s ------------------------------------------------------------ getExtensions :: Int -> Get [ExtensionRaw] getExtensions 0 = return [] getExtensions len = do 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 (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 <- HashAlgorithm <$> getWord8 s <- SignatureAlgorithm <$> getWord8 return (h, s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put putSignatureHashAlgorithm (HashAlgorithm h, SignatureAlgorithm s) = putWord8 h >> putWord8 s ------------------------------------------------------------ getServerDHParams :: Get ServerDHParams getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum16 putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p, g, y] ------------------------------------------------------------ -- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8 case curveType of 3 -> do -- ECParameters ECCurveType: curve name type grp <- Group <$> getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint case decodeGroupPublic 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 (Group grp) grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 grp -- ECParameters NamedCurve putOpaque8 $ encodeGroupPublic grppub -- ECPoint ------------------------------------------------------------ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver = DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16 putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned h sig) = putSignatureHashAlgorithm h >> putOpaque16 sig ------------------------------------------------------------ -- 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 -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getPRF :: Version -> Cipher -> PRF getPRF ver ciph | ver < TLS12 = prf_MD5SHA1 | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMainSecret_TLS :: ByteArrayAccess preMain => PRF -> preMain -> ClientRandom -> ServerRandom -> ByteString generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) = prf (B.convert preMainSecret) seed 48 where seed = B.concat ["master secret", c, s] generateMainSecret :: ByteArrayAccess preMain => Version -> Cipher -> preMain -> ClientRandom -> ServerRandom -> ByteString generateMainSecret v c = generateMainSecret_TLS $ getPRF v c generateExtendedMainSecret :: ByteArrayAccess preMain => Version -> Cipher -> preMain -> ByteString -> ByteString generateExtendedMainSecret v c preMainSecret sessionHash = getPRF v c (B.convert preMainSecret) 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) mainSecret kbsize = prf mainSecret seed kbsize where seed = B.concat ["key expansion", s, c] generateKeyBlock :: Version -> Cipher -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString generateFinished_TLS prf label mainSecret hashctx = prf mainSecret seed 12 where seed = B.concat [label, hashFinal hashctx] generateClientFinished :: Version -> Cipher -> ByteString -> HashCtx -> ByteString generateClientFinished ver ciph = generateFinished_TLS (getPRF ver ciph) "client finished" generateServerFinished :: Version -> Cipher -> ByteString -> HashCtx -> ByteString generateServerFinished ver ciph = generateFinished_TLS (getPRF ver ciph) "server finished" ------------------------------------------------------------ encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString 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 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) tls-2.1.8/Network/TLS/Packet13.hs0000644000000000000000000001770107346545000014525 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} 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 Network.TLS.ErrT import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire import System.IO.Unsafe ---------------------------------------------------------------- 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] -- TLS 1.3 does not use "select (extensions_present)". putExtensions :: [ExtensionRaw] -> Put putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do putBinaryVersion TLS12 putServerRandom32 random putSession session putWord16 $ fromCipherId cipherId putWord8 0 -- compressionID nullCompression putExtensions exts encodeHandshake13' (NewSessionTicket13 life ageadd nonce 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 (TLSCertificateChain cc) ess) = encodeCertificate13 reqctx cc ess encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts 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 (TLSCertificateChain cc) ess) = runPut $ do putWord16 1 -- zlib: fixme let bs = encodeCertificate13 reqctx cc ess putWord24 $ fromIntegral $ B.length bs putOpaque24 $ BL.toStrict $ compress $ BL.fromStrict bs encodeHandshakeHeader13 :: HandshakeType -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do putWord8 (fromHandshakeType ty) putWord24 len encodeCertificate13 :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString encodeCertificate13 reqctx cc ess = runPut $ do putOpaque8 reqctx putOpaque24 (runPut $ mapM_ putCert $ zip certs ess) where CertificateChainRaw certs = encodeCertificateChain cc putCert (certRaw, exts) = do putOpaque24 certRaw putExtensions exts ---------------------------------------------------------------- decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of GotError err -> throwError err 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 (HandshakeType, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do ty <- getHandshakeType content <- getOpaque24 return (ty, content) {- FOURMOLU_DISABLE -} decodeHandshake13 :: HandshakeType -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_ServerHello -> decodeServerHello13 HandshakeType_NewSessionTicket -> decodeNewSessionTicket13 HandshakeType_EndOfEarlyData -> return EndOfEarlyData13 HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13 HandshakeType_Certificate -> decodeCertificate13 HandshakeType_CertRequest -> decodeCertRequest13 HandshakeType_CertVerify -> decodeCertVerify13 HandshakeType_Finished -> decodeFinished13 HandshakeType_KeyUpdate -> decodeKeyUpdate13 HandshakeType_CompressedCertificate -> decodeCompressedCertificate13 (HandshakeType x) -> fail $ "Unsupported HandshakeType " ++ show x {- FOURMOLU_ENABLE -} decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do _ver <- getBinaryVersion random <- getServerRandom32 session <- getSession cipherid <- CipherId <$> getWord16 _comp <- getWord8 exts <- getWord16 >>= getExtensions . fromIntegral return $ ServerHello13 random session cipherid exts 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 decodeEncryptedExtensions13 :: Get Handshake13 decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do len <- fromIntegral <$> getWord16 getExtensions len decodeCertificate13 :: Get Handshake13 decodeCertificate13 = do reqctx <- getOpaque8 len <- fromIntegral <$> getWord24 (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 (TLSCertificateChain cc) ess where getCert = do l <- fromIntegral <$> getWord24 cert <- getBytes l len <- fromIntegral <$> getWord16 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 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16) decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes) decodeKeyUpdate13 :: Get Handshake13 decodeKeyUpdate13 = do ru <- getWord8 case ru of 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) tls-2.1.8/Network/TLS/Parameters.hs0000644000000000000000000006710007346545000015253 0ustar0000000000000000module Network.TLS.Parameters ( ClientParams (..), defaultParamsClient, ServerParams (..), defaultParamsServer, CommonParams, DebugParams (..), defaultDebugParams, ClientHooks (..), defaultClientHooks, OnCertificateRequest, OnServerCertificate, ServerHooks (..), defaultServerHooks, Supported (..), defaultSupported, Shared (..), defaultShared, Limit (..), defaultLimit, -- * Parameters MaxFragmentEnum (..), EMSMode (..), GroupUsage (..), CertificateUsage (..), CertificateRejectReason (..), Information (..), ) where import qualified Data.ByteString as B import Data.Default (Default (def)) import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto 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. re-using 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 } -- | Default value for 'DebugParams' 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 {-# 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: '[]' , 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' } deriving (Show) -- | Default value for 'ClientParams' defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams { clientUseMaxFragmentLength = Nothing , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientWantSessionResume = Nothing , clientWantSessionResumeList = [] , clientShared = def , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams , clientUseEarlyData = 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) , serverLimit :: Limit } deriving (Show) defaultParamsServer :: ServerParams defaultParamsServer = ServerParams { serverWantClientCert = False , serverCACertificates = [] , serverDHEParams = Nothing , serverHooks = def , serverShared = def , serverSupported = def , serverDebug = defaultDebugParams , serverEarlyDataSize = 0 , serverTicketLifetime = 7200 , serverLimit = defaultLimit } 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 preference 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' , supportedGroups :: [Group] -- ^ 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,FFDHE2048,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ } 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) 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 , supportedGroups = supportedNamedGroups } 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: @[]@ , 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 = [] , 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 [B.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 recommandations. , onServerFinished :: Information -> IO () -- ^ When a handshake is done, this hook can check `Information`. } defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks { onCertificateRequest = \_ -> return Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024 , onServerFinished = \_ -> return () } 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 followings: -- -- @ -- 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 prefered 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 ([B.ByteString] -> IO B.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' } -- | 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 } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks -- | Information related to a running context, e.g. current cipher data Information = Information { infoVersion :: Version , infoCipher :: Cipher , infoCompression :: Compression , infoMainSecret :: Maybe ByteString , infoExtendedMainSecret :: Bool , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom , infoSupportedGroup :: Maybe Group , infoTLS12Resumption :: Bool , infoTLS13HandshakeMode :: Maybe HandshakeMode13 , infoIsEarlyDataAccepted :: Bool } deriving (Show, Eq) -- | 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 } tls-2.1.8/Network/TLS/PostHandshake.hs0000644000000000000000000000213007346545000015674 0ustar0000000000000000module Network.TLS.PostHandshake ( requestCertificate, requestCertificateServer, postHandshakeAuthWith, postHandshakeAuthClientWith, postHandshakeAuthServerWith, ) where import Network.TLS.Context.Internal import Network.TLS.IO import Network.TLS.Struct13 import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server -- | 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 :: Context -> IO Bool requestCertificate ctx = withWriteLock ctx $ checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx -- Handle a post-handshake authentication flight with TLS 1.3. This is called -- automatically by 'recvData', in a context where the read lock is already -- taken. postHandshakeAuthWith :: Context -> Handshake13 -> IO () postHandshakeAuthWith ctx hs = withWriteLock ctx $ handleException ctx $ doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs tls-2.1.8/Network/TLS/QUIC.hs0000644000000000000000000002314307346545000013710 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- API to run the TLS handshake establishing a QUIC connection. -- -- On the northbound API: -- -- * QUIC starts a TLS client or server thread with 'tlsQUICClient' or -- 'tlsQUICServer'. -- -- TLS invokes QUIC callbacks to use the QUIC transport -- -- * TLS uses 'quicSend' and 'quicRecv' to send and receive handshake message -- fragments. -- -- * TLS calls 'quicInstallKeys' to provide to QUIC the traffic secrets it -- should use for encryption/decryption. -- -- * TLS calls 'quicNotifyExtensions' to notify to QUIC the transport parameters -- exchanged through the handshake protocol. -- -- * TLS calls 'quicDone' when the handshake is done. module Network.TLS.QUIC ( -- * Handshakers tlsQUICClient, tlsQUICServer, -- * Callback QUICCallbacks (..), CryptLevel (..), KeyScheduleEvent (..), -- * Secrets EarlySecretInfo (..), HandshakeSecretInfo (..), ApplicationSecretInfo (..), EarlySecret, HandshakeSecret, ApplicationSecret, TrafficSecrets, ServerTrafficSecret (..), ClientTrafficSecret (..), -- * Negotiated parameters NegotiatedProtocol, HandshakeMode13 (..), -- * Extensions ExtensionRaw (..), ExtensionID (ExtensionID, EID_QuicTransportParameters), -- * Errors errorTLS, errorToAlertDescription, errorToAlertMessage, fromAlertDescription, toAlertDescription, -- * Hash hkdfExpandLabel, hkdfExtract, hashDigestSize, -- * Constants quicMaxEarlyDataSize, -- * Supported defaultSupported, ) where import Network.TLS.Backend import Network.TLS.Context import Network.TLS.Context.Internal import Network.TLS.Core import Network.TLS.Crypto (hashDigestSize) import Network.TLS.Crypto.Types import Network.TLS.Extension import Network.TLS.Extra.Cipher import Network.TLS.Handshake.Common import Network.TLS.Handshake.Control import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports 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 (def) nullBackend :: Backend nullBackend = Backend { backendFlush = return () , backendClose = return () , backendSend = \_ -> return () , backendRecv = \_ -> return "" } -- | Argument given to 'quicInstallKeys' when encryption material is available. data KeyScheduleEvent = -- | 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. , 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. } newRecordLayer :: QUICCallbacks -> RecordLayer [(CryptLevel, ByteString)] newRecordLayer callbacks = newTransparentRecordLayer get send recv where 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 -- receive handshake data. tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams mylimref <- newRecordLimitRef Nothing peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ()) , ctxMyRecordLimit = mylimref , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 quicDone callbacks ctx2 void $ recvData ctx2 -- waiting for new session tickets where sync ctx (SendClientHello mEarlySecInfo) = quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) sync ctx (RecvServerHello handSecInfo) = quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo) sync ctx (SendClientFinished exts appSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do throwCore $ Error_Protocol "QUIC transport parameters are mssing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) -- | Start a TLS handshake thread for a QUIC server. The server will use the -- specified TLS parameters and call the provided callback functions to send and -- receive handshake data. tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams mylimref <- newRecordLimitRef Nothing peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync , ctxMyRecordLimit = mylimref , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 quicDone callbacks ctx2 where sync ctx (SendServerHello exts mEarlySecInfo handSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do throwCore $ Error_Protocol "QUIC transport parameters are mssing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo) sync ctx (SendServerFinished appSecInfo) = quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) filterQTP :: [ExtensionRaw] -> [ExtensionRaw] filterQTP = filter (\(ExtensionRaw eid _) -> eid == EID_QuicTransportParameters) -- | Can be used by callbacks to signal an unexpected condition. This will then -- generate an "internal_error" alert in the TLS stack. errorTLS :: String -> IO a errorTLS msg = throwCore $ Error_Protocol msg InternalError -- | Return the alert that a TLS endpoint would send to the peer for the -- specified library error. errorToAlertDescription :: TLSError -> AlertDescription errorToAlertDescription = snd . errorToAlert -- | Decode an alert from the assigned value. toAlertDescription :: Word8 -> AlertDescription toAlertDescription = AlertDescription defaultSupported :: Supported 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 quicMaxEarlyDataSize = 0xffffffff tls-2.1.8/Network/TLS/RNG.hs0000644000000000000000000000106007346545000013567 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.TLS.RNG ( StateRNG (..), Seed, seedNew, seedToInteger, seedFromInteger, withTLSRNG, newStateRNG, MonadRandom, getRandomBytes, ) where import Crypto.Random newtype StateRNG = StateRNG ChaChaDRG deriving (DRG) instance Show StateRNG where show _ = "rng[..]" withTLSRNG :: StateRNG -> MonadPseudoRandom StateRNG a -> (a, StateRNG) withTLSRNG rng f = withDRG rng f newStateRNG :: Seed -> StateRNG newStateRNG seed = StateRNG $ drgNewSeed seed tls-2.1.8/Network/TLS/Record.hs0000644000000000000000000000163407346545000014366 0ustar0000000000000000-- | 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, Ciphertext, -- * Encrypt and decrypt from the record layer encryptRecord, decryptRecord, -- * State tracking RecordM, runRecordM, RecordState (..), newRecordState, getRecordVersion, setRecordIV, ) where import Network.TLS.Record.Decrypt import Network.TLS.Record.Encrypt import Network.TLS.Record.State import Network.TLS.Record.Types tls-2.1.8/Network/TLS/Record/0000755000000000000000000000000007346545000014026 5ustar0000000000000000tls-2.1.8/Network/TLS/Record/Decrypt.hs0000644000000000000000000001766607346545000016014 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.TLS.Record.Decrypt ( decryptRecord, ) where import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..)) import qualified Data.ByteArray as B (convert, xor) import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.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 = B.xor iv sqnc | otherwise = iv `B.append` enonce (content, authTag2) = decryptF nonce econtent' ad when (AuthTag (B.convert authTag) /= authTag2) $ throwError $ Error_Protocol "bad record mac on AEAD" BadRecordMac modify incrRecordState return content decryptOf BulkStateUninitialized = throwError $ Error_Protocol "decrypt state uninitialized" InternalError -- handling of outer format can report errors with Error_Packet get3o s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) -- all format errors related to decrypted content are reported -- externally as integrity failures, i.e. BadRecordMac get3i s ls = maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ partition3 s ls get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) tls-2.1.8/Network/TLS/Record/Encrypt.hs0000644000000000000000000001135107346545000016007 0ustar0000000000000000{-# 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 qualified Data.ByteArray as B (convert, xor) 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 = 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 tls-2.1.8/Network/TLS/Record/Layer.hs0000644000000000000000000000375607346545000015451 0ustar0000000000000000module Network.TLS.Record.Layer ( 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 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 :: (Context -> IO ann) -> Context -> Record Plaintext -> IO (Either TLSError [(ann, ByteString)]) transparentEncodeRecord _ _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right [] 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 ctx (Record _ _ frag) = get ctx >>= \a -> return $ Right [(a, fragmentGetBytes frag)] 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 :: (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) = let (ys, zs) = span ((== a) . fst) xs in (a, v : map snd ys) : compress zs tls-2.1.8/Network/TLS/Record/Recv.hs0000644000000000000000000001015607346545000015264 0ustar0000000000000000-- | 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) ) tls-2.1.8/Network/TLS/Record/Send.hs0000644000000000000000000000411107346545000015250 0ustar0000000000000000-- | TLS record layer in Tx direction module Network.TLS.Record.Send ( encodeRecord12, encodeRecord13, sendBytes, ) where import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Record import Network.TLS.Struct import Control.Concurrent.MVar import Control.Monad.State.Strict import qualified Data.ByteString as B 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 tls-2.1.8/Network/TLS/Record/State.hs0000644000000000000000000001170407346545000015445 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} 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 qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.ErrT import Network.TLS.Imports import Network.TLS.MAC import Network.TLS.Packet import Network.TLS.Struct import Network.TLS.Types 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) newtype MacState = MacState { msSequence :: Word64 } deriving (Show) data RecordOptions = RecordOptions { recordVersion :: Version -- version to use when sending/receiving , recordTLS13 :: Bool -- TLS13 record processing } -- | TLS encryption level. data CryptLevel = -- | 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 data RecordState = RecordState { stCipher :: Maybe Cipher , stCompression :: Compression , stCryptLevel :: CryptLevel , stCryptState :: CryptState , stMacState :: MacState } deriving (Show) newtype RecordM a = RecordM { runRecordM :: RecordOptions -> RecordState -> Either TLSError (a, RecordState) } instance Applicative RecordM where pure a = RecordM $ \_ st -> Right (a, st) (<*>) = ap instance Monad RecordM where m1 >>= m2 = RecordM $ \opt st -> 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) getRecordOptions :: RecordM RecordOptions getRecordOptions = RecordM $ \opt st -> Right (opt, st) getRecordVersion :: RecordM Version getRecordVersion = recordVersion <$> getRecordOptions instance MonadState RecordState RecordM where 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 catchError m f = RecordM $ \opt st -> 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 } incrRecordState :: RecordState -> RecordState 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}} withCompression :: (Compression -> (Compression, a)) -> RecordM a withCompression f = do st <- get let (nc, a) = f $ stCompression st 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 $ stCipher tstate hashA = cipherHash cipher encodedSeq = encodeWord64 $ msSequence $ stMacState tstate (macF, msg) = (hmac hashA, B.concat [encodedSeq, encodeHeader hdr, content]) makeDigest :: Header -> ByteString -> RecordM ByteString makeDigest hdr content = do ver <- getRecordVersion st <- get let (digest, nstate) = computeDigest ver st hdr content put nstate return digest getBulk :: RecordM Bulk getBulk = cipherBulk . fromJust . stCipher <$> get getMacSequence :: RecordM Word64 getMacSequence = msSequence . stMacState <$> get tls-2.1.8/Network/TLS/Record/Types.hs0000644000000000000000000000510507346545000015467 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} -- | 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 (..), -- * TLS Record fragment and constructors Fragment, fragmentGetBytes, fragmentPlaintext, fragmentCiphertext, Plaintext, Ciphertext, -- * manipulate record onRecordFragment, fragmentCipher, fragmentUncipher, -- * serialize record rawToRecord, recordToRaw, recordToHeader, ) where import qualified Data.ByteString as B import Network.TLS.Imports import Network.TLS.Record.State import Network.TLS.Struct -- | Represent a TLS record. data Record a = Record ProtocolType Version (Fragment a) deriving (Show, Eq) newtype Fragment a = Fragment {fragmentGetBytes :: ByteString} deriving (Show, Eq) data Plaintext data Ciphertext fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes 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 f (Fragment b) = Fragment <$> f b -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (ByteString -> RecordM ByteString) -> Fragment Plaintext -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | 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 record into an header and bytes recordToRaw :: Record a -> (Header, ByteString) recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes) -- | turn a header and a fragment into a record rawToRecord :: Header -> Fragment a -> Record a rawToRecord (Header pt ver _) fragment = Record pt ver fragment -- | turn a record into a header recordToHeader :: Record a -> Header recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes) tls-2.1.8/Network/TLS/Session.hs0000644000000000000000000000353007346545000014570 0ustar0000000000000000module Network.TLS.Session ( SessionManager (..), noSessionManager, ) where import Network.TLS.Types -- | A session manager. -- In the server side, all fields are used. -- In the client side, only 'sessionEstablish' is used. data SessionManager = SessionManager { sessionResume :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used on TLS 1.2\/1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. , sessionResumeOnlyOnce :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used for 0RTT on TLS 1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. , sessionEstablish :: 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 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 } tls-2.1.8/Network/TLS/State.hs0000644000000000000000000003100607346545000014224 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 import Control.Monad.State.Strict import Crypto.Random import qualified Data.ByteString as B import Data.X509 (CertificateChain) import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct import Network.TLS.Types (HostName, Role (..), Ticket) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState { 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 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString)) , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , 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 ByteString , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } 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) 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 , stSecureRenegotiation = False , stClientVerifyData = Nothing , stServerVerifyData = Nothing , stServerCertificateChain = Nothing , stExtensionALPN = False , stHandshakeRecordCont = Nothing , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = 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 } 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}) 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}) 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_ServerHelloDone = True 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 -> TLSSt () setSession session = modify (\st -> st{stSession = session}) getSession :: TLSSt Session getSession = gets stSession 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}) setVersionIfUnset :: Version -> TLSSt () 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 getVersionWithDefault :: Version -> TLSSt Version getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt () setSecureRenegotiation b = modify (\st -> st{stSecureRenegotiation = b}) getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionALPN :: Bool -> TLSSt () 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}) getNegotiatedProtocol :: TLSSt (Maybe B.ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol setClientALPNSuggest :: [B.ByteString] -> TLSSt () setClientALPNSuggest ps = modify (\st -> st{stClientALPNSuggest = Just ps}) getClientALPNSuggest :: TLSSt (Maybe [B.ByteString]) getClientALPNSuggest = gets stClientALPNSuggest setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt () 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}) 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}) clearClientSNI :: TLSSt () clearClientSNI = modify (\st -> st{stClientSNI = Nothing}) getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI getVerifyData :: Role -> TLSSt VerifyData getVerifyData client = do mVerifyData <- gets (if client == ClientRole then stClientVerifyData else stServerVerifyData) return $ fromMaybe (VerifyData "") mVerifyData 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) withRNG :: MonadPseudoRandom StateRNG a -> TLSSt a withRNG f = do st <- get let (a, rng') = withTLSRNG (stRandomGen st) f put (st{stRandomGen = rng'}) return a setTLS12SessionTicket :: Ticket -> TLSSt () setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t}) getTLS12SessionTicket :: TLSSt (Maybe Ticket) getTLS12SessionTicket = gets stTLS12SessionTicket setTLS13ExporterSecret :: ByteString -> TLSSt () setTLS13ExporterSecret key = modify (\st -> st{stTLS13ExporterSecret = Just key}) getTLS13ExporterSecret :: TLSSt (Maybe ByteString) getTLS13ExporterSecret = gets stTLS13ExporterSecret setTLS13KeyShare :: Maybe KeyShare -> TLSSt () 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}) getTLS13PreSharedKey :: TLSSt (Maybe PreSharedKey) getTLS13PreSharedKey = gets stTLS13PreSharedKey setTLS13HRR :: Bool -> TLSSt () setTLS13HRR b = modify (\st -> st{stTLS13HRR = b}) getTLS13HRR :: TLSSt Bool getTLS13HRR = gets stTLS13HRR setTLS13Cookie :: Maybe Cookie -> TLSSt () setTLS13Cookie mcookie = modify (\st -> st{stTLS13Cookie = mcookie}) getTLS13Cookie :: TLSSt (Maybe Cookie) getTLS13Cookie = gets stTLS13Cookie setTLS13ClientSupportsPHA :: Bool -> TLSSt () setTLS13ClientSupportsPHA b = modify (\st -> st{stTLS13ClientSupportsPHA = b}) getTLS13ClientSupportsPHA :: TLSSt Bool getTLS13ClientSupportsPHA = gets stTLS13ClientSupportsPHA tls-2.1.8/Network/TLS/Struct.hs0000644000000000000000000004231507346545000014435 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} -- | 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 ), TLSCertificateChain (..), emptyTLSCertificateChain, Handshake (..), CH (..), packetType, typeOfHandshake, module Network.TLS.HashAndSignature, ExtensionRaw (..), ExtensionID (..), showCertificateChain, isHelloRetryRequest, hrrRandom, ) where import Data.X509 ( CertificateChain (..), DistinguishedName, certSubjectDN, getCharacterStringRawData, getDistinguishedElements, getSigned, signedObject, ) import Network.TLS.Crypto import Network.TLS.Error import {-# SOURCE #-} Network.TLS.Extension import Network.TLS.HashAndSignature import Network.TLS.Imports import Network.TLS.Types ---------------------------------------------------------------- data CipherData = CipherData { cipherDataContent :: ByteString , cipherDataMAC :: Maybe ByteString , cipherDataPadding :: Maybe (ByteString, Int) } 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 -- in the client certificate request callback. The request callback will be -- 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. 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 ------------------------------------------------------------ type Signature = ByteString data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature deriving (Eq) instance Show DigitallySigned where show (DigitallySigned hs _sig) = "DigitallySigned " ++ show hs ++ " \"...\"" ---------------------------------------------------------------- newtype ProtocolType = ProtocolType {fromProtocolType :: Word8} deriving (Eq) {- FOURMOLU_DISABLE -} pattern ProtocolType_ChangeCipherSpec :: ProtocolType pattern ProtocolType_ChangeCipherSpec = ProtocolType 20 pattern ProtocolType_Alert :: ProtocolType pattern ProtocolType_Alert = ProtocolType 21 pattern ProtocolType_Handshake :: ProtocolType pattern ProtocolType_Handshake = ProtocolType 22 pattern ProtocolType_AppData :: ProtocolType pattern ProtocolType_AppData = ProtocolType 23 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] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (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 data Header = Header ProtocolType Version Word16 deriving (Show, Eq) newtype ServerRandom = ServerRandom {unServerRandom :: ByteString} deriving (Eq) instance Show ServerRandom where show sr@(ServerRandom bs) | isHelloRetryRequest sr = "HelloRetryReqest" | otherwise = "ServerRandom " ++ showBytesHex bs 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" isHelloRetryRequest :: ServerRandom -> Bool isHelloRetryRequest = (== hrrRandom) newtype ClientRandom = ClientRandom {unClientRandom :: ByteString} deriving (Eq) instance Show ClientRandom where show (ClientRandom bs) = "ClientRandom " ++ showBytesHex bs newtype Session = Session (Maybe SessionID) deriving (Eq) instance Show Session where show (Session Nothing) = "Session \"\"" show (Session (Just bs)) = "Session " ++ showBytesHex bs {-# DEPRECATED FinishedData "use VerifyData" #-} type FinishedData = ByteString newtype VerifyData = VerifyData ByteString deriving (Eq) instance Show VerifyData where show (VerifyData bs) = showBytesHex bs ---------------------------------------------------------------- newtype HandshakeType = HandshakeType {fromHandshakeType :: Word8} deriving (Eq) {- FOURMOLU_DISABLE -} pattern HandshakeType_HelloRequest :: HandshakeType pattern HandshakeType_HelloRequest = HandshakeType 0 pattern HandshakeType_ClientHello :: HandshakeType pattern HandshakeType_ClientHello = HandshakeType 1 pattern HandshakeType_ServerHello :: HandshakeType pattern HandshakeType_ServerHello = HandshakeType 2 pattern HandshakeType_NewSessionTicket :: HandshakeType pattern HandshakeType_NewSessionTicket = HandshakeType 4 pattern HandshakeType_EndOfEarlyData :: HandshakeType pattern HandshakeType_EndOfEarlyData = HandshakeType 5 pattern HandshakeType_EncryptedExtensions :: HandshakeType pattern HandshakeType_EncryptedExtensions = HandshakeType 8 pattern HandshakeType_Certificate :: HandshakeType pattern HandshakeType_Certificate = HandshakeType 11 pattern HandshakeType_ServerKeyXchg :: HandshakeType pattern HandshakeType_ServerKeyXchg = HandshakeType 12 pattern HandshakeType_CertRequest :: HandshakeType pattern HandshakeType_CertRequest = HandshakeType 13 pattern HandshakeType_ServerHelloDone :: HandshakeType pattern HandshakeType_ServerHelloDone = HandshakeType 14 pattern HandshakeType_CertVerify :: HandshakeType pattern HandshakeType_CertVerify = HandshakeType 15 pattern HandshakeType_ClientKeyXchg :: HandshakeType pattern HandshakeType_ClientKeyXchg = HandshakeType 16 pattern HandshakeType_Finished :: HandshakeType pattern HandshakeType_Finished = HandshakeType 20 pattern HandshakeType_KeyUpdate :: HandshakeType pattern HandshakeType_KeyUpdate = HandshakeType 24 pattern HandshakeType_CompressedCertificate :: HandshakeType pattern HandshakeType_CompressedCertificate = HandshakeType 25 instance Show HandshakeType where show HandshakeType_HelloRequest = "HandshakeType_HelloRequest" show HandshakeType_ClientHello = "HandshakeType_ClientHello" show HandshakeType_ServerHello = "HandshakeType_ServerHello" show HandshakeType_Certificate = "HandshakeType_Certificate" show HandshakeType_ServerKeyXchg = "HandshakeType_ServerKeyXchg" show HandshakeType_CertRequest = "HandshakeType_CertRequest" show HandshakeType_ServerHelloDone = "HandshakeType_ServerHelloDone" show HandshakeType_CertVerify = "HandshakeType_CertVerify" show HandshakeType_ClientKeyXchg = "HandshakeType_ClientKeyXchg" show HandshakeType_Finished = "HandshakeType_Finished" show HandshakeType_NewSessionTicket = "HandshakeType_NewSessionTicket" show HandshakeType_CompressedCertificate = "HandshakeType_CompressedCertificate" show (HandshakeType x) = "HandshakeType " ++ show x {- FOURMOLU_ENABLE -} ---------------------------------------------------------------- data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum , serverDHParams_y :: BigNum } deriving (Show, Eq) serverDHParamsFrom :: DHParams -> DHPublic -> ServerDHParams serverDHParamsFrom params 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) serverDHParamsToPublic :: ServerDHParams -> DHPublic serverDHParamsToPublic serverParams = dhPublic (bigNumToInteger $ serverDHParams_y serverParams) ---------------------------------------------------------------- data ServerECDHParams = ServerECDHParams Group GroupPublic deriving (Show, Eq) ---------------------------------------------------------------- data ServerRSAParams = ServerRSAParams { rsa_modulus :: Integer , rsa_exponent :: Integer } deriving (Show, Eq) ---------------------------------------------------------------- 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_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 (Eq) {- FOURMOLU_DISABLE -} instance Show ServerKeyXchgAlgorithmData where show (SKX_DH_Anon _) = "SKX_DH_Anon" show (SKX_DHE_DSA _ _) = "SKX_DHE_DSA" show (SKX_DHE_RSA _ _) = "SKX_DHE_RSA" show (SKX_ECDHE_RSA _ _) = "SKX_ECDHE_RSA" show (SKX_ECDHE_ECDSA _ _) = "SKX_ECDHE_ECDSA" show (SKX_RSA _) = "SKX_RSA" show (SKX_DH_DSA _) = "SKX_DH_DSA" show (SKX_DH_RSA _) = "SKX_DH_RSA" show (SKX_Unparsed _) = "SKX_Unparsed" show (SKX_Unknown _) = "SKX_Unknown" {- FOURMOLU_ENABLE -} ---------------------------------------------------------------- data ClientKeyXchgAlgorithmData = CKX_RSA ByteString | CKX_DH DHPublic | CKX_ECDH ByteString deriving (Eq) instance Show ClientKeyXchgAlgorithmData where show (CKX_RSA _bs) = "CKX_RSA \"...\"" show (CKX_DH pub) = "CKX_DH " ++ show pub show (CKX_ECDH _bs) = "CKX_ECDH \"...\"" ---------------------------------------------------------------- data CH = CH { chSession :: Session , chCiphers :: [CipherId] , chExtensions :: [ExtensionRaw] } deriving (Show, Eq) newtype TLSCertificateChain = TLSCertificateChain CertificateChain deriving (Eq) instance Show TLSCertificateChain where show (TLSCertificateChain cc) = showCertificateChain cc emptyTLSCertificateChain :: TLSCertificateChain emptyTLSCertificateChain = TLSCertificateChain (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 Handshake = ClientHello Version ClientRandom [CompressionID] CH | ServerHello Version ServerRandom Session CipherId CompressionID [ExtensionRaw] | Certificate TLSCertificateChain | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] [HashAndSignatureAlgorithm] [DistinguishedName] | CertVerify DigitallySigned | Finished VerifyData | NewSessionTicket Second Ticket deriving (Show, Eq) {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType 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 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 -} tls-2.1.8/Network/TLS/Struct13.hs0000644000000000000000000000456707346545000014610 0ustar0000000000000000module Network.TLS.Struct13 ( Packet13 (..), Handshake13 (..), typeOfHandshake13, contentType, KeyUpdate (..), CertReqContext, isKeyUpdate13, ) where import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Types data Packet13 = Handshake13 [Handshake13] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString deriving (Show, Eq) data KeyUpdate = UpdateNotRequested | UpdateRequested deriving (Show, Eq) type TicketNonce = ByteString -- fixme: convert Word32 to proper data type data Handshake13 = ServerHello13 ServerRandom Session CipherId [ExtensionRaw] | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw] | Certificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]] | CertRequest13 CertReqContext [ExtensionRaw] | CertVerify13 DigitallySigned | Finished13 VerifyData | KeyUpdate13 KeyUpdate | CompressedCertificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]] deriving (Show, Eq) -- | Certificate request context for TLS 1.3. type CertReqContext = ByteString {- 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 {- FOURMOLU_ENABLE -} isKeyUpdate13 :: Handshake13 -> Bool isKeyUpdate13 (KeyUpdate13 _) = True isKeyUpdate13 _ = False tls-2.1.8/Network/TLS/Types.hs0000644000000000000000000000257407346545000014260 0ustar0000000000000000module 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, ) where import Network.Socket (HostName) import Network.TLS.Imports import Network.TLS.Types.Cipher import Network.TLS.Types.Secret import Network.TLS.Types.Session import Network.TLS.Types.Version import Network.TLS.Util.Serialization ---------------------------------------------------------------- -- | Role data Role = ClientRole | ServerRole deriving (Show, Eq) invertRole :: Role -> Role invertRole ClientRole = ServerRole invertRole ServerRole = ClientRole ---------------------------------------------------------------- -- | Direction data Direction = Tx | Rx deriving (Show, Eq) ---------------------------------------------------------------- newtype BigNum = BigNum ByteString deriving (Show, Eq) bigNumToInteger :: BigNum -> Integer bigNumToInteger (BigNum b) = os2ip b bigNumFromInteger :: Integer -> BigNum bigNumFromInteger i = BigNum $ i2osp i ---------------------------------------------------------------- -- For plaintext -- 2^14 for TLS 1.2 -- 2^14 + 1 for TLS 1.3 defaultRecordSizeLimit :: Int defaultRecordSizeLimit = 16384 tls-2.1.8/Network/TLS/Types/0000755000000000000000000000000007346545000013714 5ustar0000000000000000tls-2.1.8/Network/TLS/Types/Cipher.hs0000644000000000000000000000667607346545000015501 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.TLS.Types.Cipher where import Crypto.Cipher.Types (AuthTag) 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 ---------------------------------------------------------------- -- | 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 BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV) type BulkKey = ByteString type BulkIV = ByteString type BulkNonce = ByteString type BulkAdditionalData = ByteString newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream)) type BulkAEAD = BulkNonce -> ByteString -> BulkAdditionalData -> (ByteString, AuthTag) tls-2.1.8/Network/TLS/Types/Secret.hs0000644000000000000000000000246607346545000015505 0ustar0000000000000000module Network.TLS.Types.Secret where import Network.TLS.Imports -- | 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 ByteString deriving (Show) newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show) -- | A client traffic secret, typed with a parameter indicating a step in the -- TLS key schedule. newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show) -- | A server traffic secret, typed with a parameter indicating a step in the -- TLS key schedule. newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving (Show) data SecretTriple a = SecretTriple { triBase :: BaseSecret a , triClient :: ClientTrafficSecret a , triServer :: ServerTrafficSecret a } deriving (Show) 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) -- Main secret for TLS 1.2 or earlier. newtype MainSecret = MainSecret ByteString deriving (Show) tls-2.1.8/Network/TLS/Types/Session.hs0000644000000000000000000000363607346545000015703 0ustar0000000000000000{-# 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 , 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 tls-2.1.8/Network/TLS/Types/Version.hs0000644000000000000000000000171507346545000015701 0ustar0000000000000000{-# 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 tls-2.1.8/Network/TLS/Util.hs0000644000000000000000000000636407346545000014072 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Util ( sub, takelast, partition3, partition6, (&&!), fmapEither, catchException, forEitherM, mapChunks_, getChunks, Saved, saveMVar, restoreMVar, ) where import qualified Data.ByteString as B import Network.TLS.Imports import Control.Concurrent.MVar import Control.Exception (SomeAsyncException (..)) import qualified Control.Exception as E 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 takelast :: Int -> ByteString -> Maybe ByteString takelast i b | B.length b >= i = sub b (B.length b - i) i | otherwise = 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 -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool True &&! True = True True &&! False = False False &&! True = False False &&! False = False fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f = fmap f 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 where doTail (Right b) = fmap (b :) <$> forEitherM xs f doTail (Left e) = return (Left e) mapChunks_ :: Monad m => Maybe Int -> (B.ByteString -> m a) -> B.ByteString -> m () mapChunks_ len f = mapM_ f . getChunks len getChunks :: Maybe Int -> B.ByteString -> [B.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] -- | An opaque newtype wrapper to prevent from poking inside content that has -- been saved. newtype Saved a = Saved a -- | Save the content of an 'MVar' to restore it later. saveMVar :: MVar a -> IO (Saved a) saveMVar ref = Saved <$> readMVar ref -- | Restore the content of an 'MVar' to a previous saved value and return the -- content that has just been replaced. restoreMVar :: MVar a -> Saved a -> IO (Saved a) restoreMVar ref (Saved val) = Saved <$> swapMVar ref val tls-2.1.8/Network/TLS/Util/0000755000000000000000000000000007346545000013525 5ustar0000000000000000tls-2.1.8/Network/TLS/Util/ASN1.hs0000644000000000000000000000165007346545000014565 0ustar0000000000000000-- | ASN1 utils for TLS module Network.TLS.Util.ASN1 ( decodeASN1Object, encodeASN1Object, ) where import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.Types (ASN1Object, fromASN1, toASN1) import Network.TLS.Imports -- | Attempt to decode a bytestring representing -- an DER ASN.1 serialized object into the object. 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) Right asn1 -> case fromASN1 asn1 of 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 obj = encodeASN1' DER $ toASN1 obj [] tls-2.1.8/Network/TLS/Util/Serialization.hs0000644000000000000000000000021507346545000016674 0ustar0000000000000000module Network.TLS.Util.Serialization ( os2ip, i2osp, i2ospOf_, ) where import Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip) tls-2.1.8/Network/TLS/Wire.hs0000644000000000000000000001164107346545000014055 0ustar0000000000000000-- | 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 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 | 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 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 runGetMaybe :: Get a -> ByteString -> Maybe a runGetMaybe f = either (const Nothing) Just . G.runGet f tryGet :: Get a -> ByteString -> Maybe a tryGet f = either (const Nothing) Just . G.runGet f getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8 getWord16 :: Get Word16 getWord16 = getWord16be getWords16 :: Get [Word16] 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 a <- fromIntegral <$> getWord8 b <- fromIntegral <$> getWord8 c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c getWord32 :: Get Word32 getWord32 = getWord32be getWord64 :: Get Word64 getWord64 = getWord64be getOpaque8 :: Get ByteString getOpaque8 = getWord8 >>= getBytes . fromIntegral getOpaque16 :: Get ByteString getOpaque16 = getWord16 >>= getBytes . fromIntegral getOpaque24 :: Get ByteString getOpaque24 = getWord24 >>= getBytes getInteger16 :: Get Integer getInteger16 = os2ip <$> getOpaque16 getBigNum16 :: Get BigNum getBigNum16 = BigNum <$> getOpaque16 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) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f putWords8 :: [Word8] -> Put putWords8 l = do putWord8 $ fromIntegral (length l) mapM_ putWord8 l putWord16 :: Word16 -> Put putWord16 = putWord16be putWord32 :: Word32 -> Put putWord32 = putWord32be putWord64 :: Word64 -> Put putWord64 = putWord64be putWords16 :: [Word16] -> Put putWords16 l = do putWord16 $ 2 * fromIntegral (length l) mapM_ putWord16 l putWord24 :: Int -> Put putWord24 i = do let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff) mapM_ putWord8 [a, b, c] putBytes :: ByteString -> Put putBytes = putByteString putOpaque8 :: ByteString -> Put putOpaque8 b = putWord8 (fromIntegral $ B.length b) >> putBytes b putOpaque16 :: ByteString -> Put putOpaque16 b = putWord16 (fromIntegral $ B.length b) >> putBytes b putOpaque24 :: ByteString -> Put putOpaque24 b = putWord24 (B.length b) >> putBytes b putInteger16 :: Integer -> Put putInteger16 = putOpaque16 . i2osp putBigNum16 :: BigNum -> Put putBigNum16 (BigNum b) = putOpaque16 b encodeWord16 :: Word16 -> ByteString encodeWord16 = runPut . putWord16 encodeWord32 :: Word32 -> ByteString encodeWord32 = runPut . putWord32 encodeWord64 :: Word64 -> ByteString encodeWord64 = runPut . putWord64be tls-2.1.8/Network/TLS/X509.hs0000644000000000000000000000477607346545000013627 0ustar0000000000000000-- | 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.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 -- | Certificate and Chain rejection reason data CertificateRejectReason = CertificateRejectExpired | CertificateRejectRevoked | CertificateRejectUnknownCA | CertificateRejectAbsent | CertificateRejectOther String deriving (Show, Eq) -- | Certificate Usage callback possible returns values. 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) 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 tls-2.1.8/Setup.hs0000644000000000000000000000005707346545000012153 0ustar0000000000000000import Distribution.Simple main = defaultMain tls-2.1.8/test/0000755000000000000000000000000007346545000011474 5ustar0000000000000000tls-2.1.8/test/API.hs0000644000000000000000000000104507346545000012441 0ustar0000000000000000{-# 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 tls-2.1.8/test/Arbitrary.hs0000644000000000000000000003735307346545000014002 0ustar0000000000000000{-# 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 ver <$> arbitrary <*> arbitraryCompressionIDs <*> (CH <$> arbitrary <*> arbitraryCiphersIds <*> arbitraryHelloExtensions ver) , arbitrary >>= \ver -> ServerHello ver <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryHelloExtensions ver , Certificate . TLSCertificateChain . 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 <$> 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 (TLSCertificateChain (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 , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures } , 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 _ = arbitraryCredentialsOfEachType' >>= 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 tls-2.1.8/test/Certificate.hs0000644000000000000000000001223207346545000014252 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Certificate ( arbitraryX509, arbitraryX509WithKey, arbitraryX509WithKeyAndUsage, arbitraryDN, simpleCertificate, simpleX509, 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" tls-2.1.8/test/CiphersSpec.hs0000644000000000000000000000425207346545000014243 0ustar0000000000000000module CiphersSpec where 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 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 tls-2.1.8/test/EncodeSpec.hs0000644000000000000000000000243207346545000014041 0ustar0000000000000000module 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 tls-2.1.8/test/HandshakeSpec.hs0000644000000000000000000011334207346545000014535 0ustar0000000000000000{-# 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.Internal import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import API import Arbitrary import PipeChan import Run import Session spec :: Spec spec = do describe "pipe" $ do it "can setup a channel" pipe_work describe "handshake" $ do prop "can run TLS 1.2" handshake_simple prop "can run TLS 1.3" handshake13_simple prop "can update key for TLS 1.3" handshake_update_key prop "can prevent downgrade attack" handshake13_downgrade prop "can negotiate hash and signature" handshake_hashsignatures prop "can negotiate cipher suite" handshake_ciphersuites prop "can negotiate group" handshake_groups prop "can negotiate elliptic curve" handshake_ec prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher prop "can fallback for certificate with hash and signature" handshake_cert_fallback_hs prop "can handle server key usage" handshake_server_key_usage prop "can handle client key usage" handshake_client_key_usage prop "can authenticate client" handshake_client_auth prop "can receive client authentication failure" handshake_client_auth_fail prop "can handle extended main secret" handshake_ems prop "can resume with extended main secret" handshake_resumption_ems prop "can handle ALPN" handshake_alpn prop "can handle SNI" handshake_sni prop "can re-negotiate with TLS 1.2" handshake12_renegotiation prop "can resume session with TLS 1.2" handshake12_session_resumption prop "can resume session ticket with TLS 1.2" handshake12_session_ticket prop "can handshake with TLS 1.3 Full" handshake13_full prop "can handshake with TLS 1.3 HRR" handshake13_hrr prop "can handshake with TLS 1.3 PSK" handshake13_psk prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback prop "can handshake with TLS 1.3 EE" handshake13_ee_groups prop "can handshake with TLS 1.3 EC groups" handshake13_ec prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth -------------------------------------------------------------- pipe_work :: IO () pipe_work = do pipe <- newPipe _ <- runPipe pipe let bSize = 16 n <- generate (choose (1, 32)) let d1 = B.replicate (bSize * n) 40 let d2 = B.replicate (bSize * n) 45 d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1) d1' `shouldBe` d1 d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2) d2' `shouldBe` d2 -------------------------------------------------------------- handshake_simple :: (ClientParams, ServerParams) -> IO () handshake_simple = runTLSSimple -------------------------------------------------------------- newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) instance Arbitrary CSP13 where arbitrary = CSP13 <$> arbitraryPairParams13 handshake13_simple :: CSP13 -> IO () handshake13_simple (CSP13 params) = runTLSSimple13 params hs where cgrps = supportedGroups $ clientSupported $ fst params sgrps = supportedGroups $ serverSupported $ snd params hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest -------------------------------------------------------------- handshake13_downgrade :: (ClientParams, ServerParams) -> IO () handshake13_downgrade (cparam, sparam) = do versionForced <- generate $ elements (supportedVersions $ clientSupported cparam) let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} sparam' = sparam{serverDebug = debug'} params = (cparam, sparam') downgraded = (isVersionEnabled TLS13 params && versionForced < TLS13) || (isVersionEnabled TLS12 params && versionForced < TLS12) if downgraded then runTLSFailure params handshake handshake else runTLSSimple params handshake_update_key :: (ClientParams, ServerParams) -> IO () handshake_update_key = runTLSSimpleKeyUpdate -------------------------------------------------------------- handshake_hashsignatures :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () handshake_hashsignatures (clientHashSigs, serverHashSigs) = do tls13 <- generate arbitrary let version = if tls13 then TLS13 else TLS12 ciphers = [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 , cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 , cipher13_AES_128_GCM_SHA256 ] (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers ([version], [version]) (ciphers, ciphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = clientHashSigs } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedHashSignatures = serverHashSigs } } commonHashSigs = clientHashSigs `intersect` serverHashSigs shouldFail | tls13 = all incompatibleWithDefaultCurve commonHashSigs | otherwise = null commonHashSigs if shouldFail then runTLSFailure (clientParam', serverParam') handshake handshake else runTLSSimple (clientParam', serverParam') where incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 incompatibleWithDefaultCurve _ = False handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO () handshake_ciphersuites (clientCiphers, serverCiphers) = do tls13 <- generate arbitrary let version = if tls13 then TLS13 else TLS12 (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers ([version], [version]) (clientCiphers, serverCiphers) let adequate = cipherAllowedForVersion version shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) if shouldSucceed then runTLSSimple (clientParam, serverParam) else runTLSFailure (clientParam, serverParam) handshake handshake -------------------------------------------------------------- handshake_groups :: GGP -> IO () handshake_groups (GGP clientGroups serverGroups) = do tls13 <- generate arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = ciphersuite_strong (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) denyCustom <- generate arbitrary let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = clientGroups } , clientHooks = (clientHooks clientParam) { onCustomFFDHEGroup = \_ _ -> return groupUsage } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups } } commonGroups = clientGroups `intersect` serverGroups shouldFail = null commonGroups p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups if shouldFail then runTLSFailure (clientParam', serverParam') handshake handshake else runTLSPredicate (clientParam', serverParam') p -------------------------------------------------------------- newtype SG = SG [Group] deriving (Show) instance Arbitrary SG where arbitrary = SG <$> shuffle sigGroups where sigGroups = [P256, P521] handshake_ec :: SG -> IO () handshake_ec (SG sigGroups) = do let versions = [TLS12] ciphers = [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ] hashSignatures = [ (HashSHA256, SignatureECDSA) ] (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) clientGroups <- generate $ shuffle sigGroups clientHashSignatures <- generate $ sublistOf hashSignatures serverHashSignatures <- generate $ sublistOf hashSignatures credentials <- generate arbitraryCredentialsOfEachCurve let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = clientGroups , supportedHashSignatures = clientHashSignatures } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedGroups = sigGroups , supportedHashSignatures = serverHashSignatures } , serverShared = (serverShared serverParam) { sharedCredentials = Credentials credentials } } sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) ecdsaDenied = SignatureECDSA `notElem` sigAlgs if ecdsaDenied then runTLSFailure (clientParam', serverParam') handshake handshake else runTLSSimple (clientParam', serverParam') -- Tests ability to use or ignore client "signature_algorithms" extension when -- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but -- the server RSA certificate has a SHA-1 signature that the client does not -- support. Server may choose the DSA certificate only when cipher -- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA -- certificate. data OC = OC [Cipher] [Cipher] deriving (Show) instance Arbitrary OC where arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers where otherCiphers = [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 ] handshake_cert_fallback_cipher :: OC -> IO () handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do let clientVersions = [TLS12] serverVersions = [TLS12] commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] chainRef <- newIORef Nothing (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = hashSignatures } , clientHooks = (clientHooks clientParam) { onServerCertificate = \_ _ _ chain -> writeIORef chainRef (Just chain) >> return [] } } runTLSSimple (clientParam', serverParam) serverChain <- readIORef chainRef isLeafRSA serverChain `shouldBe` True -- Same as above but testing with supportedHashSignatures directly instead of -- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the -- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by -- both client and server, the Ed25519 certificate is selected. Otherwise the -- server fallbacks to RSA. -- -- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 -- unless client advertises explicit support. Currently this is not enforced by -- the library, which is useful to test this scenario. SHA-1 could be replaced -- by another algorithm. data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm] deriving (Show) instance Arbitrary OHS where arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS where otherHS = [(HashIntrinsic, SignatureEd25519)] handshake_cert_fallback_hs :: OHS -> IO () handshake_cert_fallback_hs (OHS clientHS serverHS) = do tls13 <- generate arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = [ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 , cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 , cipher13_AES_128_GCM_SHA256 ] commonHS = [ (HashSHA256, SignatureRSA) , (HashIntrinsic, SignatureRSApssRSAeSHA256) ] chainRef <- newIORef Nothing (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = commonHS ++ clientHS } , clientHooks = (clientHooks clientParam) { onServerCertificate = \_ _ _ chain -> writeIORef chainRef (Just chain) >> return [] } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedHashSignatures = commonHS ++ serverHS } } eddsaDisallowed = (HashIntrinsic, SignatureEd25519) `notElem` clientHS || (HashIntrinsic, SignatureEd25519) `notElem` serverHS runTLSSimple (clientParam', serverParam') serverChain <- readIORef chainRef isLeafRSA serverChain `shouldBe` eddsaDisallowed -------------------------------------------------------------- handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO () handshake_server_key_usage usageFlags = do tls13 <- generate arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = ciphersuite_all (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) cred <- generate $ arbitraryRSACredentialWithUsage usageFlags let serverParam' = serverParam { serverShared = (serverShared serverParam) { sharedCredentials = Credentials [cred] } } shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags if shouldSucceed then runTLSSimple (clientParam, serverParam') else runTLSFailure (clientParam, serverParam') handshake handshake handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO () handshake_client_key_usage usageFlags = do (clientParam, serverParam) <- generate arbitrary cred <- generate $ arbitraryRSACredentialWithUsage usageFlags let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverWantClientCert = True , serverHooks = (serverHooks serverParam) { onClientCertificate = \_ -> return CertificateUsageAccept } } shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags if shouldSucceed then runTLSSimple (clientParam', serverParam') else runTLSFailure (clientParam', serverParam') handshake handshake -------------------------------------------------------------- handshake_client_auth :: (ClientParams, ServerParams) -> IO () handshake_client_auth (clientParam, serverParam) = do let clientVersions = supportedVersions $ clientSupported clientParam serverVersions = supportedVersions $ serverSupported serverParam version = maximum (clientVersions `intersect` serverVersions) cred <- generate (arbitraryClientCredential version) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverWantClientCert = True , serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } } runTLSSimple (clientParam', serverParam') where validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO () handshake_client_auth_fail (clientParam, serverParam) = do let clientVersions = supportedVersions $ clientSupported clientParam serverVersions = supportedVersions $ serverSupported serverParam version = maximum (clientVersions `intersect` serverVersions) cred <- generate (arbitraryClientCredential version) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverWantClientCert = True , serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } } runTLSFailure (clientParam', serverParam') handshake handshake where validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA) -------------------------------------------------------------- handshake_ems :: (EMSMode, EMSMode) -> IO () handshake_ems (cems, sems) = do params <- generate arbitrary let params' = setEMSMode (cems, sems) params version = getConnectVersion params' emsVersion = version >= TLS10 && version <= TLS12 use = cems /= NoEMS && sems /= NoEMS require = cems == RequireEMS || sems == RequireEMS p info = infoExtendedMainSecret info == (emsVersion && use) if emsVersion && require && not use then runTLSFailure params' handshake handshake else runTLSPredicate params' (maybe False p) newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show) instance Arbitrary CompatEMS where arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible) where compatible (NoEMS, RequireEMS) = False compatible (RequireEMS, NoEMS) = False compatible _ = True handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO () handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs plainParams <- generate arbitrary let params = setEMSMode ems $ setPairParamsSessionManagers sessionManagers plainParams runTLSSimple params -- and resume sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let params2 = setEMSMode ems2 $ setPairParamsSessionResuming (fromJust sessionParams) params let version = getConnectVersion params2 emsVersion = version >= TLS10 && version <= TLS12 if emsVersion && use ems && not (use ems2) then runTLSFailure params2 handshake handshake else do runTLSSimple params2 mSessionParams2 <- readClientSessionRef sessionRefs let sameSession = sessionParams == mSessionParams2 sameUse = use ems == use ems2 when emsVersion (sameSession `shouldBe` sameUse) where use (NoEMS, _) = False use (_, NoEMS) = False use _ = True -------------------------------------------------------------- handshake_alpn :: (ClientParams, ServerParams) -> IO () handshake_alpn (clientParam, serverParam) = do let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onSuggestALPN = return $ Just ["h2", "http/1.1"] } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onALPNClientSuggest = Just alpn } } params' = (clientParam', serverParam') runTLSSuccess params' hsClient hsServer where hsClient ctx = do handshake ctx proto <- getNegotiatedProtocol ctx proto `shouldBe` Just "h2" hsServer ctx = do handshake ctx proto <- getNegotiatedProtocol ctx proto `shouldBe` Just "h2" alpn xs | "h2" `elem` xs = return "h2" | otherwise = return "http/1.1" handshake_sni :: (ClientParams, ServerParams) -> IO () handshake_sni (clientParam, serverParam) = do ref <- newIORef Nothing let clientParam' = clientParam { clientServerIdentification = (serverName, "") } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onServerNameIndication = onSNI ref } } params' = (clientParam', serverParam') runTLSSuccess params' hsClient hsServer receivedName <- readIORef ref receivedName `shouldBe` Just (Just serverName) where hsClient ctx = do handshake ctx msni <- getClientSNI ctx expectMaybe "C: SNI should be Just" serverName msni hsServer ctx = do handshake ctx msni <- getClientSNI ctx expectMaybe "S: SNI should be Just" serverName msni onSNI ref name = do mx <- readIORef ref mx `shouldBe` Nothing writeIORef ref (Just name) return (Credentials []) serverName = "haskell.org" -------------------------------------------------------------- newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show) instance Arbitrary CSP12 where arbitrary = CSP12 <$> arbitraryPairParams12 handshake12_renegotiation :: CSP12 -> IO () handshake12_renegotiation (CSP12 (cparams, sparams)) = do renegDisabled <- generate arbitrary let sparams' = sparams { serverSupported = (serverSupported sparams) { supportedClientInitiatedRenegotiation = not renegDisabled } } if renegDisabled then runTLSFailure (cparams, sparams') hsClient hsServer else runTLSSimple (cparams, sparams') where hsClient ctx = handshake ctx >> handshake ctx -- recvData receives the alert from the second handshake hsServer ctx = handshake ctx >> void (recvData ctx) handshake12_session_resumption :: CSP12 -> IO () handshake12_session_resumption (CSP12 plainParams) = do sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers plainParams runTLSSimple params -- and resume sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPredicate params2 (maybe False infoTLS12Resumption) handshake12_session_ticket :: CSP12 -> IO () handshake12_session_ticket (CSP12 plainParams) = do sessionRefs <- twoSessionRefs let sessionManagers0 = twoSessionManagers sessionRefs sessionManagers = (fst sessionManagers0, oneSessionTicket) let params = setPairParamsSessionManagers sessionManagers plainParams runTLSSimple params -- and resume sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPredicate params2 (maybe False infoTLS12Resumption) -------------------------------------------------------------- handshake13_full :: CSP13 -> IO () handshake13_full (CSP13 (cli, srv)) = do let cliSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) runTLSSimple13 params FullHandshake handshake13_hrr :: CSP13 -> IO () handshake13_hrr (CSP13 (cli, srv)) = do let cliSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) runTLSSimple13 params HelloRetryRequest handshake13_psk :: CSP13 -> IO () handshake13_psk (CSP13 (cli, srv)) = do let cliSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params0 = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSSimple13 params HelloRetryRequest -- and resume sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSSimple13 params2 PreSharedKey handshake13_psk_ticket :: CSP13 -> IO () handshake13_psk_ticket (CSP13 (cli, srv)) = do let cliSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params0 = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) sessionRefs <- twoSessionRefs let sessionManagers0 = twoSessionManagers sessionRefs sessionManagers = (fst sessionManagers0, oneSessionTicket) let params = setPairParamsSessionManagers sessionManagers params0 runTLSSimple13 params HelloRetryRequest -- and resume sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSSimple13 params2 PreSharedKey handshake13_psk_fallback :: CSP13 -> IO () handshake13_psk_fallback (CSP13 (cli, srv)) = do let cliSupported = defaultSupported { supportedCiphers = [ cipher13_AES_128_GCM_SHA256 , cipher13_AES_128_CCM_SHA256 ] , supportedGroups = [P256, X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params0 = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSSimple13 params HelloRetryRequest -- resumption fails because GCM cipher is not supported anymore, full -- handshake is not possible because X25519 has been removed, so we are -- back with P256 after hello retry sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params srv2' = srv2{serverSupported = svrSupported'} svrSupported' = defaultSupported { supportedCiphers = [cipher13_AES_128_CCM_SHA256] , supportedGroups = [P256] } runTLSSimple13 (cli2, srv2') HelloRetryRequest handshake13_0rtt :: CSP13 -> IO () handshake13_0rtt (CSP13 (cli, srv)) = do let cliSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } cliHooks = defaultClientHooks { onSuggestALPN = return $ Just ["h2"] } svrHooks = defaultServerHooks { onALPNClientSuggest = Just (return . unsafeHead) } params0 = ( cli { clientSupported = cliSupported , clientHooks = cliHooks } , srv { serverSupported = svrSupported , serverHooks = svrHooks , serverEarlyDataSize = 2048 } ) sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSSimple13 params HelloRetryRequest runTLS0rtt params sessionRefs runTLS0rtt params sessionRefs where runTLS0rtt params sessionRefs = do -- and resume sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams clearClientSessionRef sessionRefs earlyData <- B.pack <$> generate (someWords8 256) let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params params2 = (pc{clientUseEarlyData = True}, ps) runTLS0RTT params2 RTT0 earlyData handshake13_0rtt_fallback :: CSP13 -> IO () handshake13_0rtt_fallback (CSP13 (cli, srv)) = do group0 <- generate $ elements [P256, X25519] let cliSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group0] } params = ( cli{clientSupported = cliSupported} , srv { serverSupported = svrSupported , serverEarlyDataSize = 1024 } ) sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params0 = setPairParamsSessionManagers sessionManagers params let mode = if group0 == P256 then FullHandshake else HelloRetryRequest runTLSSimple13 params0 mode -- and resume mSessionParams <- readClientSessionRef sessionRefs case mSessionParams of Nothing -> expectationFailure "session params: Just is expected" Just sessionParams -> do earlyData <- B.pack <$> generate (someWords8 256) group1 <- generate $ elements [P256, X25519] let (pc, ps) = setPairParamsSessionResuming sessionParams params0 svrSupported1 = defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group1] } params1 = ( pc{clientUseEarlyData = True} , ps { serverEarlyDataSize = 0 , serverSupported = svrSupported1 } ) -- C: [P256, X25519] -- S: [group0] -- C: [P256, X25519] -- S: [group1] if group0 == group1 -- 0-RTT is not allowed, so fallback to PreSharedKey then runTLS0RTT params1 PreSharedKey earlyData -- HRR but not allowed for 0-RTT else runTLSFailure params1 (tlsClient earlyData) tlsServer where tlsClient earlyData ctx = do handshake ctx sendData ctx $ L.fromStrict earlyData _ <- recvData ctx bye ctx tlsServer ctx = do handshake ctx _ <- recvData ctx bye ctx handshake13_ee_groups :: CSP13 -> IO () handshake13_ee_groups (CSP13 (cli, srv)) = do let -- The client prefers P256 cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} -- The server prefers X25519 svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]} params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) (_, serverMessages) <- runTLSCapture13 params -- The server should tell X25519 in supported_groups in EE to clinet let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups eeMessagesHaveExt = [ any isSupportedGroups exts | EncryptedExtensions13 exts <- serverMessages ] eeMessagesHaveExt `shouldBe` [True] handshake13_ec :: CSP13 -> IO () handshake13_ec (CSP13 (cli, srv)) = do EC cgrps <- generate arbitrary EC sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps} svrSupported = (serverSupported srv){supportedGroups = sgrps} params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) runTLSSimple13 params FullHandshake handshake13_ffdhe :: CSP13 -> IO () handshake13_ffdhe (CSP13 (cli, srv)) = do FFDHE cgrps <- generate arbitrary FFDHE sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps} svrSupported = (serverSupported srv){supportedGroups = sgrps} params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) runTLSSimple13 params FullHandshake post_handshake_auth :: CSP13 -> IO () post_handshake_auth (CSP13 (clientParam, serverParam)) = do cred <- generate (arbitraryClientCredential TLS13) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } } if isCredentialDSA cred then runTLSFailure (clientParam', serverParam') hsClient hsServer else runTLSSuccess (clientParam', serverParam') hsClient hsServer where validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) hsClient ctx = do handshake ctx sendData ctx "request 1" recvDataAssert ctx "response 1" sendData ctx "request 2" recvDataAssert ctx "response 2" hsServer ctx = do handshake ctx recvDataAssert ctx "request 1" _ <- requestCertificate ctx -- single request sendData ctx "response 1" recvDataAssert ctx "request 2" _ <- requestCertificate ctx _ <- requestCertificate ctx -- two simultaneously sendData ctx "response 2" expectJust :: String -> Maybe a -> Expectation expectJust tag mx = case mx of Nothing -> expectationFailure tag Just _ -> return () tls-2.1.8/test/PipeChan.hs0000644000000000000000000000456707346545000013533 0ustar0000000000000000{-# 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) tls-2.1.8/test/PubKey.hs0000644000000000000000000001104107346545000013224 0ustar0000000000000000module 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 ] 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" tls-2.1.8/test/Run.hs0000644000000000000000000002040507346545000012575 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} module Run ( runTLS, runTLSSimple, runTLSPredicate, runTLSSimple13, runTLS0RTT, runTLSSimpleKeyUpdate, runTLSCapture13, runTLSSuccess, runTLSFailure, expectMaybe, ) 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 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 = [] 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 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 tls-2.1.8/test/Session.hs0000644000000000000000000000643207346545000013460 0ustar0000000000000000{-# 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 tls-2.1.8/test/Spec.hs0000644000000000000000000000005407346545000012721 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} tls-2.1.8/test/ThreadSpec.hs0000644000000000000000000000237707346545000014063 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ThreadSpec where import Control.Concurrent import Control.Concurrent.Async import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.Foldable (traverse_) import Network.TLS import Test.Hspec import Test.Hspec.QuickCheck import API import Arbitrary () import Run spec :: Spec spec = do describe "thread safety" $ do prop "can read/write concurrently" $ \params -> runTLS params tlsClient tlsServer tlsClient :: Chan ByteString -> Context -> IO () tlsClient queue ctx = do handshake ctx runReaderWriters ctx "server-value" "client-value" d <- readChan queue sendData ctx (L.fromChunks [d]) checkCtxFinished ctx bye ctx tlsServer :: Context -> Chan [ByteString] -> IO () tlsServer ctx queue = do handshake ctx runReaderWriters ctx "client-value" "server-value" d <- recvData ctx writeChan queue [d] checkCtxFinished ctx bye ctx runReaderWriters :: Context -> ByteString -> L.ByteString -> IO () runReaderWriters ctx r w = -- run concurrently 10 readers and 10 writers on the same context let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] in runConcurrently $ traverse_ Concurrently workers tls-2.1.8/tls.cabal0000644000000000000000000001411707346545000012307 0ustar0000000000000000cabal-version: >=1.10 name: tls version: 2.1.8 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez maintainer: Kazu Yamamoto author: Vincent Hanquez homepage: https://github.com/haskell-tls/hs-tls synopsis: TLS protocol native implementation description: Native Haskell TLS 1.2/1.3 protocol implementation for servers and clients. category: Network build-type: Simple extra-source-files: test/*.hs CHANGELOG.md source-repository head type: git location: https://github.com/haskell-tls/hs-tls subdir: core flag devel description: Development commands default: False library exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher Network.TLS.Extra.FFDHE Network.TLS.QUIC other-modules: Network.TLS.Struct Network.TLS.Struct13 Network.TLS.Core Network.TLS.Context Network.TLS.Context.Internal Network.TLS.Credentials Network.TLS.Backend Network.TLS.Crypto Network.TLS.Crypto.DH Network.TLS.Crypto.IES Network.TLS.Crypto.Types Network.TLS.ErrT Network.TLS.Error Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Certificate Network.TLS.Handshake.Client Network.TLS.Handshake.Client.ClientHello Network.TLS.Handshake.Client.Common Network.TLS.Handshake.Client.ServerHello Network.TLS.Handshake.Client.TLS12 Network.TLS.Handshake.Client.TLS13 Network.TLS.Handshake.Common Network.TLS.Handshake.Common13 Network.TLS.Handshake.Control Network.TLS.Handshake.Key Network.TLS.Handshake.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.HashAndSignature Network.TLS.Hooks Network.TLS.IO Network.TLS.IO.Decode Network.TLS.IO.Encode Network.TLS.Imports Network.TLS.KeySchedule Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.PostHandshake Network.TLS.RNG Network.TLS.Record Network.TLS.Record.Decrypt Network.TLS.Record.Encrypt Network.TLS.Record.Layer Network.TLS.Record.Recv Network.TLS.Record.Send Network.TLS.Record.State Network.TLS.Record.Types Network.TLS.Session Network.TLS.State Network.TLS.Types Network.TLS.Types.Cipher Network.TLS.Types.Secret Network.TLS.Types.Session Network.TLS.Types.Version Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization Network.TLS.Wire Network.TLS.X509 default-extensions: Strict StrictData default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.9 && <5, asn1-encoding >= 0.9 && < 0.10, asn1-types >= 0.3 && < 0.4, base16-bytestring, bytestring >= 0.10 && < 0.13, cereal >= 0.5.3 && < 0.6, crypton >= 0.34, crypton-x509 >= 1.7 && < 1.8, crypton-x509-store >= 1.6 && < 1.7, crypton-x509-validation >= 1.6.13 && < 1.7, data-default, memory >= 0.18 && < 0.19, mtl >= 2.2 && < 2.4, network >= 3.1, serialise >= 0.2 && < 0.3, transformers >= 0.5 && < 0.7, unix-time >= 0.4.11 && < 0.5, zlib >= 0.7 && < 0.8 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test other-modules: API Arbitrary Certificate CiphersSpec EncodeSpec HandshakeSpec PipeChan PubKey Run Session ThreadSpec default-extensions: Strict StrictData default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, QuickCheck, asn1-types, async, bytestring, crypton, crypton-x509, crypton-x509-validation, hourglass, hspec, serialise, tls 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, bytestring, base16-bytestring, containers, crypton, crypton-x509-store, crypton-x509-system, network, network-run, tls if flag(devel) else buildable: False executable tls-client main-is: tls-client.hs hs-source-dirs: util other-modules: Client Common Imports default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, base16-bytestring, bytestring, crypton, crypton-x509-store, crypton-x509-system, network, network-run, tls if flag(devel) else buildable: False tls-2.1.8/util/0000755000000000000000000000000007346545000011472 5ustar0000000000000000tls-2.1.8/util/Client.hs0000644000000000000000000000301707346545000013245 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Client ( Aux (..), Cli, clientHTTP11, clientDNS, ) where import qualified Data.ByteString.Base16 as BS16 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 $ "GET " <> CL8.fromStrict (NE.head paths) <> " HTTP/1.1\r\n" <> "Host: " <> CL8.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 tls-2.1.8/util/Common.hs0000644000000000000000000000674607346545000013273 0ustar0000000000000000{-# 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, ) where 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) ] namedGroups :: [(String, Group)] namedGroups = [ ("ffdhe2048", FFDHE2048) , ("ffdhe3072", FFDHE3072) , ("ffdhe4096", FFDHE4096) , ("ffdhe6144", FFDHE6144) , ("ffdhe8192", FFDHE8192) , ("p256", P256) , ("p384", P384) , ("p521", P521) , ("x25519", X25519) , ("x448", X448) ] 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 = case traverse (`lookup` namedGroups) (split ',' s) of Nothing -> [] Just gs -> gs 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 "Erro: 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) tls-2.1.8/util/Imports.hs0000644000000000000000000000053207346545000013463 0ustar0000000000000000module 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 tls-2.1.8/util/Server.hs0000644000000000000000000000473507346545000013305 0ustar0000000000000000{-# 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 BL8 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 :: BL8.ByteString html = BL8.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 $ BL8.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 $ BL8.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 (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 tls-2.1.8/util/tls-client.hs0000644000000000000000000002751607346545000014117 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main where import Control.Concurrent 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.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 } 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 } usage :: String usage = "Usage: quic-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" ] 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 () showContent | optShow = C8.putStr | otherwise = \_ -> return () aux = Aux { auxAuthority = host , auxPort = port , auxDebugPrint = debug , auxShow = showContent , auxReadResumptionData = readIORef ref } mstore <- if optValidate then Just <$> getSystemCertificateStore else return Nothing let cparams = getClientParams opts host port (smIORef ref) mstore onCertReq 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 = runTCPClient auxAuthority auxPort $ \sock -> do ctx <- contextNew sock cparams when optDebugLog $ contextHookSetLogging ctx defaultLogging { loggingPacketSent = putStrLn . (">> " ++) , loggingPacketRecv = putStrLn . ("<< " ++) } handshake ctx r <- action ctx bye ctx return r modifyClientParams :: ClientParams -> [(SessionID, SessionData)] -> Bool -> ClientParams modifyClientParams cparams ts early = cparams { clientWantSessionResumeList = ts , clientUseEarlyData = early } getClientParams :: Options -> HostName -> ServiceName -> SessionManager -> Maybe CertificateStore -> OnCertificateRequest -> ClientParams getClientParams Options{..} serverName port sm mstore onCertReq = (defaultParamsClient serverName (C8.pack port)) { clientSupported = supported , clientUseServerNameIndication = True , clientShared = shared , clientHooks = hooks , clientDebug = debug } where groups | optRetry = FFDHE8192 : optGroups | otherwise = optGroups shared = defaultShared { sharedSessionManager = sm , sharedCAStore = case mstore of Just store -> store Nothing -> mempty , sharedValidationCache = validateCache } 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 } 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 tls-2.1.8/util/tls-server.hs0000644000000000000000000001477607346545000014153 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main where import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as C8 import Data.IORef import qualified Data.Map.Strict as M import Data.X509.CertificateStore import Network.Run.TCP import Network.TLS 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 } 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" } 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" ] usage :: String usage = "Usage: 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 <- if optClientAuth then do mstore' <- case optTrustedAnchor of Nothing -> Just <$> getSystemCertificateStore Just file -> readCertificateStore file when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor" return mstore' else return Nothing let keyLog = getLogger optKeyLogFile creds = Credentials [cred] makeCipherShowPretty runTCPServer (Just host) port $ \sock -> do let sparams = getServerParams creds optGroups smgr keyLog mstore ctx <- contextNew sock sparams when optDebugLog $ contextHookSetLogging ctx defaultLogging { loggingPacketSent = putStrLn . ("<< " ++) , loggingPacketRecv = putStrLn . (">> " ++) } when (optDebugLog || optShow) $ putStrLn "------------------------" handshake ctx when optDebugLog $ getInfo ctx >>= printHandshakeInfo server ctx optShow bye ctx getServerParams :: Credentials -> [Group] -> SessionManager -> (String -> IO ()) -> Maybe CertificateStore -> ServerParams getServerParams creds groups sm keyLog mstore = defaultParamsServer { serverSupported = supported , serverShared = shared , serverHooks = hooks , serverDebug = debug , serverEarlyDataSize = 2048 , serverWantClientCert = isJust mstore } where shared = defaultShared { sharedCredentials = creds , sharedSessionManager = sm , sharedCAStore = case mstore of Just store -> store Nothing -> sharedCAStore defaultShared } 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} 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 C8.putStrLn $ "sessionResume: " <> BS16.encode key M.lookup key <$> readIORef ref , sessionResumeOnlyOnce = \key -> do C8.putStrLn $ "sessionResumeOnlyOnce: " <> BS16.encode key M.lookup key <$> readIORef ref , sessionEstablish = \key val -> do C8.putStrLn $ "sessionEstablish: " <> BS16.encode key atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing) , sessionInvalidate = \key -> do C8.putStrLn $ "sessionEstablish: " <> BS16.encode key atomicModifyIORef' ref $ \m -> (M.delete key m, ()) , sessionUseTicket = False }