tls-1.5.4/0000755000000000000000000000000013623162342010513 5ustar0000000000000000tls-1.5.4/Setup.hs0000644000000000000000000000005613623162342012150 0ustar0000000000000000import Distribution.Simple main = defaultMain tls-1.5.4/LICENSE0000644000000000000000000000273113623162342011523 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-1.5.4/CHANGELOG.md0000644000000000000000000003452313623162342012333 0ustar0000000000000000## 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-1.5.4/tls.cabal0000644000000000000000000001514113623162342012303 0ustar0000000000000000Name: tls Version: 1.5.4 Description: Native Haskell TLS and SSL protocol implementation for server and client. . This provides a high-level implementation of a sensitive security protocol, eliminating a common set of security issues through the use of the advanced type system, high level constructions and common Haskell features. . Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 protocol, and support RSA and Ephemeral (Elliptic curve and regular) Diffie Hellman key exchanges, and many extensions. . Some debug tools linked with tls, are available through the . License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez Maintainer: Vincent Hanquez Synopsis: TLS/SSL protocol native implementation (Server and Client) Build-Type: Simple Category: Network stability: experimental Cabal-Version: >=1.8 Homepage: http://github.com/vincenthz/hs-tls extra-source-files: Tests/*.hs CHANGELOG.md Flag compat Description: Accept SSLv2 client hello for beginning SSLv3 / TLS handshake Default: True Flag network Description: Use the base network library Default: True Flag hans Description: Use the Haskell Network Stack (HaNS) Default: False Library Build-Depends: base >= 4.9 && < 5 , mtl >= 2 , transformers , cereal >= 0.5.3 , bytestring , data-default-class -- crypto related , memory >= 0.14.6 , cryptonite >= 0.25 -- certificate related , asn1-types >= 0.2.0 , asn1-encoding , x509 >= 1.7.5 , x509-store >= 1.6 , x509-validation >= 1.6.5 , async >= 2.0 , hourglass if flag(network) Build-Depends: network >= 2.4.0.0 cpp-options: -DINCLUDE_NETWORK if flag(hans) Build-Depends: hans cpp-options: -DINCLUDE_HANS Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher Network.TLS.Extra.FFDHE other-modules: Network.TLS.Cap Network.TLS.Struct Network.TLS.Struct13 Network.TLS.Core Network.TLS.Context Network.TLS.Context.Internal Network.TLS.Credentials Network.TLS.Backend Network.TLS.Crypto Network.TLS.Crypto.DH Network.TLS.Crypto.IES Network.TLS.Crypto.Types Network.TLS.ErrT Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Common Network.TLS.Handshake.Common13 Network.TLS.Handshake.Certificate Network.TLS.Handshake.Key Network.TLS.Handshake.Client Network.TLS.Handshake.Server Network.TLS.Handshake.Process Network.TLS.Handshake.Random Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13 Network.TLS.Hooks Network.TLS.IO Network.TLS.Imports Network.TLS.KeySchedule Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.PostHandshake Network.TLS.Record Network.TLS.Record.Types Network.TLS.Record.Engage Network.TLS.Record.Disengage Network.TLS.Record.State Network.TLS.RNG Network.TLS.State Network.TLS.Session Network.TLS.Sending Network.TLS.Sending13 Network.TLS.Receiving Network.TLS.Receiving13 Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization Network.TLS.Types Network.TLS.Wire Network.TLS.X509 ghc-options: -Wall if flag(compat) cpp-options: -DSSLV2_COMPATIBLE Test-Suite test-tls type: exitcode-stdio-1.0 hs-source-dirs: Tests Main-is: Tests.hs other-modules: Certificate Ciphers Connection Marshalling PipeChan PubKey Build-Depends: base >= 3 && < 5 , async >= 2.0 , data-default-class , tasty , tasty-quickcheck , tls , QuickCheck , cryptonite , bytestring , asn1-types , x509 , x509-validation , hourglass ghc-options: -Wall -fno-warn-unused-imports Benchmark bench-tls hs-source-dirs: Benchmarks Tests Main-Is: Benchmarks.hs type: exitcode-stdio-1.0 other-modules: Certificate Connection PipeChan PubKey Build-depends: base >= 4 && < 5 , tls , x509 , x509-validation , data-default-class , cryptonite , gauge , bytestring , asn1-types , async >= 2.0 , hourglass , QuickCheck >= 2 , tasty-quickcheck , tls ghc-options: -Wall -fno-warn-unused-imports source-repository head type: git location: https://github.com/vincenthz/hs-tls subdir: core tls-1.5.4/Network/0000755000000000000000000000000013623162342012144 5ustar0000000000000000tls-1.5.4/Network/TLS.hs0000644000000000000000000001254313623162342013147 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Native Haskell TLS and SSL protocol implementation for server and -- client. -- -- This provides a high-level implementation of a sensitive security -- protocol, eliminating a common set of security issues through the -- use of the advanced type system, high level constructions and -- common Haskell features. -- -- Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions. -- -- Some debug tools linked with tls, are available through the -- http://hackage.haskell.org/package/tls-debug/. module Network.TLS ( -- * Basic APIs Context , contextNew , handshake , sendData , recvData , bye -- * Backend abstraction , HasBackend(..) , Backend(..) -- * Parameters -- intentionally hide the internal methods even haddock warns. , TLSParams , ClientParams(..) , defaultParamsClient , ServerParams(..) -- ** Shared , Shared(..) -- ** Hooks , ClientHooks(..) , OnCertificateRequest , OnServerCertificate , ServerHooks(..) , Measurement(..) -- ** Supported , Supported(..) -- ** Debug parameters , DebugParams(..) -- * Shared parameters -- ** Credentials , Credentials(..) , Credential , credentialLoadX509 , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory -- ** Session manager , SessionManager(..) , noSessionManager , SessionID , SessionData(..) , SessionFlag(..) , TLS13TicketInfo -- ** Validation Cache , ValidationCache(..) , ValidationCacheQueryCallback , ValidationCacheAddCallback , ValidationCacheResult(..) , exceptionValidationCache -- * Types -- ** For 'Supported' , Version(..) , Compression(..) , nullCompression , HashAndSignatureAlgorithm , HashAlgorithm(..) , SignatureAlgorithm(..) , Group(..) , EMSMode(..) -- ** For parameters and hooks , DHParams , DHPublic , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) , CertificateType(..) , HostName , MaxFragmentEnum(..) -- * Advanced APIs -- ** Backend , ctxConnection , contextFlush , contextClose -- ** Information gathering , Information(..) , contextGetInformation , ClientRandom , ServerRandom , unClientRandom , unServerRandom , HandshakeMode13(..) , getClientCertificateChain -- ** Negotiated , getNegotiatedProtocol , getClientSNI -- ** Post-handshake actions , updateKey , KeyUpdateRequest(..) , requestCertificate -- ** Modifying hooks in context , Hooks(..) , contextModifyHooks , Handshake , contextHookSetHandshakeRecv , Handshake13 , contextHookSetHandshake13Recv , contextHookSetCertificateRecv , Logging(..) , 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' , contextNewOnHandle #ifdef INCLUDE_NETWORK , contextNewOnSocket #endif , Bytes , ValidationChecks(..) , ValidationHooks(..) ) where import Network.TLS.Backend (Backend(..), HasBackend(..)) import Network.TLS.Cipher import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) import Network.TLS.Context import Network.TLS.Core import Network.TLS.Credentials import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) import Network.TLS.Handshake.State (HandshakeMode13(..)) import Network.TLS.Hooks import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Session import qualified Network.TLS.State as S import Network.TLS.Struct ( TLSError(..), TLSException(..) , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..) , Header(..), ProtocolType(..), CertificateType(..) , AlertDescription(..) , ClientRandom(..), ServerRandom(..) , Handshake) import Network.TLS.Struct13 ( Handshake13 ) import Network.TLS.Types import Network.TLS.X509 import Data.ByteString as B import Data.X509 (PubKey(..), PrivKey(..)) import Data.X509.Validation hiding (HostName) {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-} type Bytes = B.ByteString -- | 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 tls-1.5.4/Network/TLS/0000755000000000000000000000000013623162342012606 5ustar0000000000000000tls-1.5.4/Network/TLS/Packet.hs0000644000000000000000000006561313623162342014364 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Packet -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Packet module contains everything necessary to serialize and deserialize things -- with only explicit parameters, no TLS state is involved here. -- module Network.TLS.Packet ( -- * params for encoding and decoding CurrentParams(..) -- * marshall functions for header messages , decodeHeader , decodeDeprecatedHeaderLength , decodeDeprecatedHeader , encodeHeader , encodeHeaderNoVer -- use for SSL3 -- * marshall functions for alert messages , decodeAlert , decodeAlerts , encodeAlerts -- * marshall functions for handshake messages , decodeHandshakeRecord , decodeHandshake , decodeDeprecatedHandshake , encodeHandshake , encodeHandshakeHeader , encodeHandshakeContent -- * marshall functions for change cipher spec message , decodeChangeCipherSpec , encodeChangeCipherSpec , decodePreMasterSecret , encodePreMasterSecret , encodeSignedDHParams , encodeSignedECDHParams , decodeReallyServerKeyXchgAlgorithmData -- * generate things for packet content , generateMasterSecret , generateExtendedMasterSec , generateKeyBlock , generateClientFinished , generateServerFinished , generateCertificateVerify_SSL , generateCertificateVerify_SSL_DSS -- * for extensions parsing , getSignatureHashAlgorithm , putSignatureHashAlgorithm , getBinaryVersion , putBinaryVersion , getClientRandom32 , putClientRandom32 , getServerRandom32 , putServerRandom32 , getExtensions , putExtension , getSession , putSession , putDNames , getDNames ) where import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..)) import Network.TLS.Util.ASN1 import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as B (convert) data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type } deriving (Show,Eq) {- marshall helpers -} getVersion :: Get Version getVersion = do major <- getWord8 minor <- getWord8 case verOfNum (major, minor) of Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) Just v -> return v getBinaryVersion :: Get (Maybe Version) getBinaryVersion = do major <- getWord8 minor <- getWord8 return $ verOfNum (major, minor) putBinaryVersion :: Version -> Put putBinaryVersion ver = putWord8 major >> putWord8 minor where (major, minor) = numericalVer ver getHeaderType :: Get ProtocolType getHeaderType = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid header type: " ++ show ty) Just t -> return t putHeaderType :: ProtocolType -> Put putHeaderType = putWord8 . valOfType getHandshakeType :: Get HandshakeType getHandshakeType = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid handshake type: " ++ show ty) Just t -> return t {- - decode and encode headers -} decodeHeader :: ByteString -> Either TLSError Header decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getVersion <*> getWord16 decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16 decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16 decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header decodeDeprecatedHeader size = runGetErr "deprecatedheader" $ do 1 <- getWord8 version <- getVersion return $ Header ProtocolType_DeprecatedHandshake version size encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) {- FIXME check len <= 2^14 -} encodeHeaderNoVer :: Header -> ByteString encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len) {- FIXME check len <= 2^14 -} {- - decode and encode ALERT -} decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do al <- getWord8 ad <- getWord8 case (valToType al, valToType ad) of (Just a, Just d) -> return (a, d) (Nothing, _) -> fail "cannot decode alert level" (_, Nothing) -> fail "cannot decode alert description" 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 (valOfType al) >> putWord8 (valOfType ad) {- decode and encode HANDSHAKE -} decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType content <- getOpaque24 return (ty, content) decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello HandshakeType_ServerHello -> decodeServerHello HandshakeType_Certificate -> decodeCertificates HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp HandshakeType_CertRequest -> decodeCertRequest cp HandshakeType_ServerHelloDone -> decodeServerHelloDone HandshakeType_CertVerify -> decodeCertVerify cp HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp HandshakeType_Finished -> decodeFinished decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where getDeprecated = do 1 <- getWord8 ver <- getVersion cipherSpecLen <- fromEnum <$> getWord16 sessionIdLen <- fromEnum <$> getWord16 challengeLen <- fromEnum <$> getWord16 ciphers <- getCipherSpec cipherSpecLen session <- getSessionId sessionIdLen random <- getChallenge challengeLen let compressions = [0] return $ ClientHello ver random session ciphers compressions [] (Just b) getCipherSpec len | len < 3 = return [] getCipherSpec len = do [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) getSessionId 0 = return $ Session Nothing getSessionId len = Session . Just <$> getBytes len getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest decodeClientHello :: Get Handshake decodeClientHello = do ver <- getVersion random <- getClientRandom32 session <- getSession ciphers <- getWords16 compressions <- getWords8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake decodeServerHello = do ver <- getVersion random <- getServerRandom32 session <- getSession cipherid <- getWord16 compressionid <- getWord8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone decodeCertificates :: Get Handshake decodeCertificates = do certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) Right cc -> return $ Certificates cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) decodeFinished :: Get Handshake decodeFinished = Finished <$> (remaining >>= getBytes) decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do mcertTypes <- map (valToType . fromIntegral) <$> getWords8 certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes sigHashAlgs <- if cParamsVersion cp >= TLS12 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) else return Nothing CertRequest certTypes sigHashAlgs <$> getDNames where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) -- | Decode a list CA distinguished names getDNames :: Get [DistinguishedName] getDNames = do dNameLen <- getWord16 -- FIXME: Decide whether to remove this check completely or to make it an option. -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size" getList (fromIntegral dNameLen) getDName where getDName = do dName <- getOpaque16 when (B.length dName == 0) $ fail "certrequest: invalid DN length" dn <- either fail return $ decodeASN1Object "cert request DistinguishedName" dName return (2 + B.length dName, dn) decodeCertVerify :: CurrentParams -> Get Handshake decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp) decodeClientKeyXchg :: CurrentParams -> Get Handshake decodeClientKeyXchg cp = -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of Nothing -> error "no client key exchange type" Just cke -> ClientKeyXchg <$> parseCKE cke where parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes) parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic parseCKE CipherKeyExchange_DHE_DSS = parseClientDHPublic parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic parseCKE _ = error "unsupported client key exchange type" parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16 parseClientECDHPublic = CKX_ECDH <$> getOpaque8 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 decodeServerKeyXchgAlgorithmData :: Version -> CipherKeyExchangeType -> Get ServerKeyXchgAlgorithmData decodeServerKeyXchgAlgorithmData ver cke = toCKE where toCKE = case cke of CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH CipherKeyExchange_DHE_RSA -> do dhparams <- getServerDHParams signature <- getDigitallySigned ver return $ SKX_DHE_RSA dhparams signature CipherKeyExchange_DHE_DSS -> do dhparams <- getServerDHParams signature <- getDigitallySigned ver return $ SKX_DHE_DSS dhparams signature CipherKeyExchange_ECDHE_RSA -> do ecdhparams <- getServerECDHParams signature <- getDigitallySigned ver return $ SKX_ECDHE_RSA ecdhparams signature CipherKeyExchange_ECDHE_ECDSA -> do ecdhparams <- getServerECDHParams signature <- getDigitallySigned ver return $ SKX_ECDHE_ECDSA ecdhparams signature _ -> do bs <- remaining >>= getBytes return $ SKX_Unknown bs decodeServerKeyXchg :: CurrentParams -> Get Handshake decodeServerKeyXchg cp = case cParamsKeyXchgType cp of Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = runPut $ encodeHandshakeContent o in let len = B.length content in let header = case o of ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in B.concat [ header, content ] encodeHandshakeHeader :: HandshakeType -> Int -> Put encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len encodeHandshakeContent :: Handshake -> Put encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do putBytes deprecated encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do putBinaryVersion version putClientRandom32 random putSession session putWords16 cipherIDs putWords8 compressionIDs putExtensions exts return () encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = do putBinaryVersion version putServerRandom32 random putSession session putWord16 cipherid putWord8 compressionID putExtensions exts return () encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) where (CertificateChainRaw certs) = encodeCertificateChain cc encodeHandshakeContent (ClientKeyXchg ckx) = do case ckx of CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic CKX_ECDH bytes -> putOpaque8 bytes encodeHandshakeContent (ServerKeyXchg skg) = case skg of SKX_RSA _ -> error "encodeHandshakeContent SKX_RSA not implemented" SKX_DH_Anon params -> putServerDHParams params SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_Unparsed bytes -> putBytes bytes _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) encodeHandshakeContent HelloRequest = return () encodeHandshakeContent ServerHelloDone = return () encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do putWords8 (map valOfType certTypes) case sigAlgs of Nothing -> return () Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l putDNames certAuthorities encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned encodeHandshakeContent (Finished opaque) = putBytes opaque ------------------------------------------------------------ -- | 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 -> 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 <- getWord16 extdatalen <- getWord16 extdata <- getBytes $ fromIntegral extdatalen extxs <- getExtensions (len - fromIntegral extdatalen - 4) return $ ExtensionRaw extty extdata : extxs putExtension :: ExtensionRaw -> Put putExtension (ExtensionRaw ty l) = putWord16 ty >> putOpaque16 l putExtensions :: [ExtensionRaw] -> Put putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" return (h,s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put putSignatureHashAlgorithm (h,s) = putWord8 (valOfType h) >> putWord8 (valOfType 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 mgrp <- toEnumSafe16 <$> getWord16 -- ECParameters NamedCurve case mgrp of Nothing -> error "getServerECDHParams: unknown group" Just grp -> do mxy <- getOpaque8 -- ECPoint case decodeGroupPublic grp mxy of Left e -> error $ "getServerECDHParams: " ++ show e Right grppub -> return $ ServerECDHParams grp grppub _ -> error "getServerECDHParams: unknown type for ECDH Params" -- RFC 4492 Section 5.4 Server Key Exchange putServerECDHParams :: ServerECDHParams -> Put putServerECDHParams (ServerECDHParams grp grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve putOpaque8 $ encodeGroupPublic grppub -- ECPoint getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned ver | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm) <*> getOpaque16 | otherwise = DigitallySigned Nothing <$> getOpaque16 putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned mhash sig) = maybe (return ()) putSignatureHashAlgorithm mhash >> putOpaque16 sig {- - decode and encode ALERT -} decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do x <- getWord8 when (x /= 1) (fail "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) -- rsa pre master secret decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString) decodePreMasterSecret = runGetErr "pre-master-secret" $ (,) <$> getVersion <*> getBytes 46 encodePreMasterSecret :: Version -> ByteString -> ByteString encodePreMasterSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) -- | in certain cases, we haven't manage to decode ServerKeyExchange properly, -- because the decoding was too eager and the cipher wasn't been set yet. -- we keep the Server Key Exchange in it unparsed format, and this function is -- able to really decode the server key xchange if it's unparsed. decodeReallyServerKeyXchgAlgorithmData :: Version -> CipherKeyExchangeType -> ByteString -> Either TLSError ServerKeyXchgAlgorithmData decodeReallyServerKeyXchgAlgorithmData ver cke = runGetErr "server-key-xchg-algorithm-data" (decodeServerKeyXchgAlgorithmData ver cke) {- - 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 generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = B.concat $ map computeMD5 ["A","BB","CCC"] where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ] computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ] generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) = prf (B.convert premasterSecret) seed 48 where seed = B.concat [ "master secret", c, s ] generateMasterSecret :: ByteArrayAccess preMaster => Version -> Cipher -> preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret SSL2 _ = generateMasterSecret_SSL generateMasterSecret SSL3 _ = generateMasterSecret_SSL generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c generateExtendedMasterSec :: ByteArrayAccess preMaster => Version -> Cipher -> preMaster -> ByteString -> ByteString generateExtendedMasterSec v c premasterSecret sessionHash = getPRF v c (B.convert premasterSecret) seed 48 where seed = B.append "extended master secret" sessionHash generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ] generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] computeMD5 label = hash MD5 $ B.concat [ mastersecret, computeSHA1 label ] computeSHA1 label = hash SHA1 $ B.concat [ label, mastersecret, s, c ] generateKeyBlock :: Version -> Cipher -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock SSL2 _ = generateKeyBlock_SSL generateKeyBlock SSL3 _ = generateKeyBlock_SSL generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 where seed = B.concat [ label, hashFinal hashctx ] generateFinished_SSL :: ByteString -> ByteString -> HashCtx -> ByteString generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] where md5hash = hash MD5 $ B.concat [ mastersecret, pad2, md5left ] sha1hash = hash SHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1) $ foldl hashUpdate hashctx [sender,mastersecret] (md5left,sha1left) = B.splitAt 16 lefthash pad2 = B.replicate 48 0x5c pad1 = B.replicate 48 0x36 generateClientFinished :: Version -> Cipher -> ByteString -> HashCtx -> ByteString generateClientFinished ver ciph | ver < TLS10 = generateFinished_SSL "CLNT" | otherwise = generateFinished_TLS (getPRF ver ciph) "client finished" generateServerFinished :: Version -> Cipher -> ByteString -> HashCtx -> ByteString generateServerFinished ver ciph | ver < TLS10 = generateFinished_SSL "SRVR" | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" {- returns *output* after final MD5/SHA1 -} generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL = generateFinished_SSL "" {- returns *input* before final SHA1 -} generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash where toHash = B.concat [ mastersecret, pad2, sha1left ] sha1left = hashFinal $ flip hashUpdate pad1 $ hashUpdate hashctx mastersecret pad2 = B.replicate 40 0x5c pad1 = B.replicate 40 0x36 encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams -- 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 fromJustM :: MonadFail m => String -> Maybe a -> m a fromJustM what Nothing = fail ("fromJustM " ++ what ++ ": Nothing") fromJustM _ (Just x) = return x tls-1.5.4/Network/TLS/Record.hs0000644000000000000000000000216313623162342014362 0ustar0000000000000000-- | -- Module : Network.TLS.Record -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- The Record Protocol takes messages to be transmitted, fragments the -- data into manageable blocks, optionally compresses the data, applies -- a MAC, encrypts, and transmits the result. Received data is -- decrypted, verified, decompressed, reassembled, and then delivered to -- higher-level clients. -- module Network.TLS.Record ( Record(..) -- * Fragment manipulation types , Fragment , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext , recordToRaw , rawToRecord , recordToHeader , Plaintext , Compressed , Ciphertext -- * Engage and disengage from the record layer , engageRecord , disengageRecord -- * State tracking , RecordM , runRecordM , RecordState(..) , newRecordState , getRecordVersion , setRecordIV ) where import Network.TLS.Record.Types import Network.TLS.Record.Engage import Network.TLS.Record.Disengage import Network.TLS.Record.State tls-1.5.4/Network/TLS/Parameters.hs0000644000000000000000000006435413623162342015261 0ustar0000000000000000-- | -- Module : Network.TLS.Parameters -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Parameters ( ClientParams(..) , ServerParams(..) , CommonParams , DebugParams(..) , ClientHooks(..) , OnCertificateRequest , OnServerCertificate , ServerHooks(..) , Supported(..) , Shared(..) -- * special default , defaultParamsClient -- * Parameters , MaxFragmentEnum(..) , EMSMode(..) , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) ) where import Network.TLS.Extension import Network.TLS.Struct import qualified Network.TLS.Struct as Struct import Network.TLS.Session import Network.TLS.Cipher import Network.TLS.Measurement import Network.TLS.Compression import Network.TLS.Crypto import Network.TLS.Credentials import Network.TLS.X509 import Network.TLS.RNG (Seed) import Network.TLS.Imports import Network.TLS.Types (HostName) import Data.Default.Class import qualified Data.ByteString as B type CommonParams = (Supported, Shared, DebugParams) -- | All settings should not be used in production data DebugParams = DebugParams { -- | Disable the true randomness in favor of deterministic seed that will produce -- a deterministic random from. This is useful for tests and debugging purpose. -- Do not use in production -- -- Default: 'Nothing' debugSeed :: Maybe Seed -- | Add a way to print the seed that was randomly generated. re-using the same seed -- will reproduce the same randomness with 'debugSeed' -- -- Default: no printing , debugPrintSeed :: Seed -> IO () -- | Force to choose this version in the server side. -- -- Default: 'Nothing' , debugVersionForced :: Maybe Version -- | Printing master keys. -- -- Default: no printing , debugKeyLogger :: String -> IO () } defaultDebugParams :: DebugParams defaultDebugParams = DebugParams { debugSeed = Nothing , debugPrintSeed = const (return ()) , debugVersionForced = Nothing , debugKeyLogger = \_ -> return () } instance Show DebugParams where show _ = "DebugParams" instance Default DebugParams where def = defaultDebugParams data ClientParams = ClientParams { -- | -- -- Default: 'Nothing' clientUseMaxFragmentLength :: Maybe MaxFragmentEnum -- | Define the name of the server, along with an extra service identification blob. -- this is important that the hostname part is properly filled for security reason, -- as it allow to properly associate the remote side with the given certificate -- during a handshake. -- -- The extra blob is useful to differentiate services running on the same host, but that -- might have different certificates given. It's only used as part of the X509 validation -- infrastructure. -- -- This value is typically set by 'defaultParamsClient'. , clientServerIdentification :: (HostName, ByteString) -- | Allow the use of the Server Name Indication TLS extension during handshake, which allow -- the client to specify which host name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). -- -- Default: 'True' , clientUseServerNameIndication :: Bool -- | try to establish a connection using this session. -- -- Default: 'Nothing' , clientWantSessionResume :: Maybe (SessionID, SessionData) -- | See the default value of 'Shared'. , clientShared :: Shared -- | See the default value of 'ClientHooks'. , clientHooks :: ClientHooks -- | In this element, you'll need to override the default empty value of -- of 'supportedCiphers' with a suitable cipherlist. -- -- See the default value of 'Supported'. , clientSupported :: Supported -- | See the default value of 'DebugParams'. , clientDebug :: DebugParams -- | Client tries to send this early data in TLS 1.3 if possible. -- If not accepted by the server, it is application's responsibility -- to re-sent it. -- -- Default: 'Nothing' , clientEarlyData :: Maybe ByteString } deriving (Show) defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams { clientUseMaxFragmentLength = Nothing , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientWantSessionResume = Nothing , clientShared = def , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams , clientEarlyData = Nothing } data ServerParams = ServerParams { -- | Request a certificate from client. -- -- Default: 'False' serverWantClientCert :: Bool -- | This is a list of certificates from which the -- disinguished names are sent in certificate request -- messages. For TLS1.0, it should not be empty. -- -- Default: '[]' , serverCACertificates :: [SignedCertificate] -- | Server Optional Diffie Hellman parameters. Setting parameters is -- necessary for FFDHE key exchange when clients are not compatible -- with RFC 7919. -- -- Value can be one of the standardized groups from module -- "Network.TLS.Extra.FFDHE" or custom parameters generated with -- 'Crypto.PubKey.DH.generateParams'. -- -- Default: 'Nothing' , serverDHEParams :: Maybe DHParams -- | See the default value of 'ServerHooks'. , serverHooks :: ServerHooks -- | See the default value of 'Shared'. , serverShared :: Shared -- | See the default value of 'Supported'. , serverSupported :: Supported -- | See the default value of 'DebugParams'. , serverDebug :: DebugParams -- | Server accepts this size of early data in TLS 1.3. -- 0 (or lower) means that the server does not accept early data. -- -- Default: 0 , serverEarlyDataSize :: Int -- | Lifetime in seconds for session tickets generated by the server. -- Acceptable value range is 0 to 604800 (7 days). The default lifetime -- is 86400 seconds (1 day). -- -- Default: 86400 (one day) , serverTicketLifetime :: Int } deriving (Show) defaultParamsServer :: ServerParams defaultParamsServer = ServerParams { serverWantClientCert = False , serverCACertificates = [] , serverDHEParams = Nothing , serverHooks = def , serverShared = def , serverSupported = def , serverDebug = defaultDebugParams , serverEarlyDataSize = 0 , serverTicketLifetime = 86400 } instance Default ServerParams where def = defaultParamsServer -- | List all the supported algorithms, versions, ciphers, etc supported. data Supported = Supported { -- | Supported versions by this context. On the client side, the highest -- version will be used to establish the connection. On the server side, -- the highest version that is less or equal than the client version will -- be chosen. -- -- Versions should be listed in preference order, i.e. higher versions -- first. -- -- Default: @[TLS13,TLS12,TLS11,TLS10]@ supportedVersions :: [Version] -- | Supported cipher methods. The default is empty, specify a suitable -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often -- a good choice. -- -- Default: @[]@ , supportedCiphers :: [Cipher] -- | Supported compressions methods. By default only the "null" -- compression is supported, which means no compression will be performed. -- Allowing other compression method is not advised as it causes a -- connection failure when TLS 1.3 is negotiated. -- -- Default: @[nullCompression]@ , supportedCompressions :: [Compression] -- | All supported hash/signature algorithms pair for client -- certificate verification and server signature in (EC)DHE, -- ordered by decreasing priority. -- -- This list is sent to the peer as part of the "signature_algorithms" -- extension. It is used to restrict accepted signatures received from -- the peer at TLS level (not in X.509 certificates), but only when the -- TLS version is 1.2 or above. In order to disable SHA-1 one must then -- also disable earlier protocol versions in 'supportedVersions'. -- -- The list also impacts the selection of possible algorithms when -- generating signatures. -- -- Note: with TLS 1.3 some algorithms have been deprecated and will not be -- used even when listed in the parameter: MD5, SHA-1, SHA-224, RSA -- PKCS#1, DSS. -- -- Default: -- -- @ -- [ (HashIntrinsic, SignatureEd448) -- , (HashIntrinsic, SignatureEd25519) -- , (Struct.HashSHA256, SignatureECDSA) -- , (Struct.HashSHA384, SignatureECDSA) -- , (Struct.HashSHA512, SignatureECDSA) -- , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- , (Struct.HashSHA512, SignatureRSA) -- , (Struct.HashSHA384, SignatureRSA) -- , (Struct.HashSHA256, SignatureRSA) -- , (Struct.HashSHA1, SignatureRSA) -- , (Struct.HashSHA1, SignatureDSS) -- ] -- @ , supportedHashSignatures :: [HashAndSignatureAlgorithm] -- | Secure renegotiation defined in RFC5746. -- If 'True', clients send the renegotiation_info extension. -- If 'True', servers handle the extension or the renegotiation SCSV -- then send the renegotiation_info extension. -- -- Default: 'True' , supportedSecureRenegotiation :: Bool -- | If 'True', renegotiation is allowed from the client side. -- This is vulnerable to DOS attacks. -- If 'False', renegotiation is allowed only from the server side -- via HelloRequest. -- -- Default: 'False' , supportedClientInitiatedRenegotiation :: Bool -- | The mode regarding extended master secret. Enabling this extension -- provides better security for TLS versions 1.0 to 1.2. TLS 1.3 provides -- the security properties natively and does not need the extension. -- -- By default the extension is enabled but not required. If mode is set -- to 'RequireEMS', the handshake will fail when the peer does not support -- the extension. It is also advised to disable SSLv3 which does not have -- this mechanism. -- -- Default: 'AllowEMS' , supportedExtendedMasterSec :: EMSMode -- | Set if we support session. -- -- Default: 'True' , supportedSession :: Bool -- | Support for fallback SCSV defined in RFC7507. -- If 'True', servers reject handshakes which suggest -- a lower protocol than the highest protocol supported. -- -- Default: 'True' , supportedFallbackScsv :: Bool -- | In ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed -- by an attacker. Hence, an empty packet is normally sent before a normal data packet, to -- prevent guessability. Some Microsoft TLS-based protocol implementations, however, -- consider these empty packets as a protocol violation and disconnect. If this parameter is -- 'False', empty packets will never be added, which is less secure, but might help in rare -- cases. -- -- Default: 'True' , supportedEmptyPacket :: Bool -- | A list of supported elliptic curves and finite-field groups in the -- preferred order. -- -- The list is sent to the server as part of the "supported_groups" -- extension. It is used in both clients and servers to restrict -- accepted groups in DH key exchange. Up until TLS v1.2, it is also -- used by a client to restrict accepted elliptic curves in ECDSA -- signatures. -- -- The default value includes all groups with security strength of 128 -- bits or more. -- -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ , supportedGroups :: [Group] } deriving (Show,Eq) -- | Client or server policy regarding Extended Master Secret data EMSMode = NoEMS -- ^ Extended Master Secret is not used | AllowEMS -- ^ Extended Master Secret is allowed | RequireEMS -- ^ Extended Master Secret is required deriving (Show,Eq) defaultSupported :: Supported defaultSupported = Supported { supportedVersions = [TLS13,TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] , supportedHashSignatures = [ (HashIntrinsic, SignatureEd448) , (HashIntrinsic, SignatureEd25519) , (Struct.HashSHA256, SignatureECDSA) , (Struct.HashSHA384, SignatureECDSA) , (Struct.HashSHA512, SignatureECDSA) , (HashIntrinsic, SignatureRSApssRSAeSHA512) , (HashIntrinsic, SignatureRSApssRSAeSHA384) , (HashIntrinsic, SignatureRSApssRSAeSHA256) , (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA256, SignatureRSA) , (Struct.HashSHA1, SignatureRSA) , (Struct.HashSHA1, SignatureDSS) ] , supportedSecureRenegotiation = True , supportedClientInitiatedRenegotiation = False , supportedExtendedMasterSec = AllowEMS , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True , supportedGroups = [X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521] } instance Default Supported where def = defaultSupported -- | Parameters that are common to clients and servers. data Shared = Shared { -- | The list of certificates and private keys that a server will use as -- part of authentication to clients. Actual credentials that are used -- are selected dynamically from this list based on client capabilities. -- Additional credentials returned by 'onServerNameIndication' are also -- considered. -- -- When credential list is left empty (the default value), no key -- exchange can take place. -- -- Default: 'mempty' sharedCredentials :: Credentials -- | Callbacks used by clients and servers in order to resume TLS -- sessions. The default implementation never resumes sessions. Package -- -- provides an in-memory implementation. -- -- Default: 'noSessionManager' , sharedSessionManager :: SessionManager -- | A collection of trust anchors to be used by a client as -- part of validation of server certificates. This is set as -- first argument to function 'onServerCertificate'. Package -- -- gives access to a default certificate store configured in the -- system. -- -- Default: 'mempty' , sharedCAStore :: CertificateStore -- | Callbacks that may be used by a client to cache certificate -- validation results (positive or negative) and avoid expensive -- signature check. The default implementation does not have -- any caching. -- -- See the default value of 'ValidationCache'. , sharedValidationCache :: ValidationCache } instance Show Shared where show _ = "Shared" instance Default Shared where def = Shared { sharedCredentials = mempty , sharedSessionManager = noSessionManager , sharedCAStore = mempty , sharedValidationCache = def } -- | Group usage callback possible return values. data GroupUsage = GroupUsageValid -- ^ usage of group accepted | GroupUsageInsecure -- ^ usage of group provides insufficient security | GroupUsageUnsupported String -- ^ usage of group rejected for other reason (specified as string) | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value deriving (Show,Eq) defaultGroupUsage :: Int -> DHParams -> DHPublic -> IO GroupUsage defaultGroupUsage minBits params public | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime" | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator" | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic -- To prevent Logjam attack | dhParamsGetBits params < minBits = return GroupUsageInsecure | otherwise = return GroupUsageValid -- | Type for 'onCertificateRequest'. This type synonym is to make -- document readable. type OnCertificateRequest = ([CertificateType], Maybe [HashAndSignatureAlgorithm], [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey)) -- | Type for 'onServerCertificate'. This type synonym is to make -- document readable. type OnServerCertificate = CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] -- | A set of callbacks run by the clients for various corners of TLS establishment data ClientHooks = ClientHooks { -- | This action is called when the a certificate request is -- received from the server. The callback argument is the -- information from the request. The server, at its -- discretion, may be willing to continue the handshake -- without a client certificate. Therefore, the callback is -- free to return 'Nothing' to indicate that no client -- certificate should be sent, despite the server's request. -- In some cases it may be appropriate to get user consent -- before sending the certificate; the content of the user's -- certificate may be sensitive and intended only for -- specific servers. -- -- The action should select a certificate chain of one of -- the given certificate types and one of the certificates -- in the chain should (if possible) be signed by one of the -- given distinguished names. Some servers, that don't have -- a narrow set of preferred issuer CAs, will send an empty -- 'DistinguishedName' list, rather than send all the names -- from their trusted CA bundle. If the client does not -- have a certificate chaining to a matching CA, it may -- choose a default certificate instead. -- -- Each certificate except the last should be signed by the -- following one. The returned private key must be for the -- first certificates in the chain. This key will be used -- to signing the certificate verify message. -- -- The public key in the first certificate, and the matching -- returned private key must be compatible with one of the -- list of 'HashAndSignatureAlgorithm' value when provided. -- TLS 1.3 changes the meaning of the list elements, adding -- explicit code points for each supported pair of hash and -- signature (public key) algorithms, rather than combining -- separate codes for the hash and key. For details see -- -- section 4.2.3. When no compatible certificate chain is -- available, return 'Nothing' if it is OK to continue -- without a client certificate. Returning a non-matching -- certificate should result in a handshake failure. -- -- While the TLS version is not provided to the callback, -- the content of the @signature_algorithms@ list provides -- a strong hint, since TLS 1.3 servers will generally list -- RSA pairs with a hash component of 'Intrinsic' (@0x08@). -- -- Note that is is the responsibility of this action to -- select a certificate matching one of the requested -- certificate types (public key algorithms). Returning -- a non-matching one will lead to handshake failure later. -- -- Default: returns 'Nothing' anyway. onCertificateRequest :: OnCertificateRequest -- | Used by the client to validate the server certificate. The default -- implementation calls 'validateDefault' which validates according to the -- default hooks and checks provided by "Data.X509.Validation". This can -- be replaced with a custom validation function using different settings. -- -- The function is not expected to verify the key-usage extension of the -- end-entity certificate, as this depends on the dynamically-selected -- cipher and this part should not be cached. Key-usage verification -- is performed by the library internally. -- -- Default: 'validateDefault' , onServerCertificate :: OnServerCertificate -- | This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. -- -- Default: returns 'Nothing' , onSuggestALPN :: IO (Maybe [B.ByteString]) -- | This action is called to validate DHE parameters when the server -- selected a finite-field group not part of the "Supported Groups -- Registry" or not part of 'supportedGroups' list. -- -- With TLS 1.3 custom groups have been removed from the protocol, so -- this callback is only used when the version negotiated is 1.2 or -- below. -- -- The default behavior with (dh_p, dh_g, dh_size) and pub as follows: -- -- (1) rejecting if dh_p is even -- (2) rejecting unless 1 < dh_g && dh_g < dh_p - 1 -- (3) rejecting unless 1 < dh_p && pub < dh_p - 1 -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack) -- -- See RFC 7919 section 3.1 for recommandations. , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage } defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks { onCertificateRequest = \ _ -> return Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024 } instance Show ClientHooks where show _ = "ClientHooks" instance Default ClientHooks where def = defaultClientHooks -- | A set of callbacks run by the server for various corners of the TLS establishment data ServerHooks = ServerHooks { -- | This action is called when a client certificate chain -- is received from the client. When it returns a -- CertificateUsageReject value, the handshake is aborted. -- -- The function is not expected to verify the key-usage -- extension of the certificate. This verification is -- performed by the library internally. -- -- Default: returns the followings: -- -- @ -- CertificateUsageReject (CertificateRejectOther "no client certificates expected") -- @ onClientCertificate :: CertificateChain -> IO CertificateUsage -- | This action is called when the client certificate -- cannot be verified. Return 'True' to accept the certificate -- anyway, or 'False' to fail verification. -- -- Default: returns 'False' , onUnverifiedClientCert :: IO Bool -- | Allow the server to choose the cipher relative to the -- the client version and the client list of ciphers. -- -- This could be useful with old clients and as a workaround -- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1) -- -- The client cipher list cannot be empty. -- -- Default: taking the head of ciphers. , onCipherChoosing :: Version -> [Cipher] -> Cipher -- | Allow the server to indicate additional credentials -- to be used depending on the host name indicated by the -- client. -- -- This is most useful for transparent proxies where -- credentials must be generated on the fly according to -- the host the client is trying to connect to. -- -- Returned credentials may be ignored if a client does not support -- the signature algorithms used in the certificate chain. -- -- Default: returns 'mempty' , onServerNameIndication :: Maybe HostName -> IO Credentials -- | At each new handshake, we call this hook to see if we allow handshake to happens. -- -- Default: returns 'True' , onNewHandshake :: Measurement -> IO Bool -- | Allow the server to choose an application layer protocol -- suggested from the client through the ALPN -- (Application Layer Protocol Negotiation) extensions. -- -- Default: 'Nothing' , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) } defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks { onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False , onCipherChoosing = \_ -> head , onServerNameIndication = \_ -> return mempty , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks tls-1.5.4/Network/TLS/Extension.hs0000644000000000000000000007001013623162342015114 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | -- Module : Network.TLS.Extension -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- basic extensions are defined in RFC 6066 -- module Network.TLS.Extension ( Extension(..) , supportedExtensions , definedExtensions -- all extensions ID supported , extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_SecureRenegotiation , extensionID_ApplicationLayerProtocolNegotiation , extensionID_ExtendedMasterSecret , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_Heartbeat , extensionID_SignatureAlgorithms , extensionID_PreSharedKey , extensionID_EarlyData , extensionID_SupportedVersions , extensionID_Cookie , extensionID_PskKeyExchangeModes , extensionID_CertificateAuthorities , extensionID_OidFilters , extensionID_PostHandshakeAuth , extensionID_SignatureAlgorithmsCert , extensionID_KeyShare -- all implemented extensions , ServerNameType(..) , ServerName(..) , MaxFragmentLength(..) , MaxFragmentEnum(..) , SecureRenegotiation(..) , ApplicationLayerProtocolNegotiation(..) , ExtendedMasterSecret(..) , NegotiatedGroups(..) , Group(..) , EcPointFormatsSupported(..) , EcPointFormat(..) , SessionTicket(..) , HeartBeat(..) , HeartBeatMode(..) , SignatureAlgorithms(..) , SignatureAlgorithmsCert(..) , SupportedVersions(..) , KeyShare(..) , KeyShareEntry(..) , MessageType(..) , PostHandshakeAuth(..) , PskKexMode(..) , PskKeyExchangeModes(..) , PskIdentity(..) , PreSharedKey(..) , EarlyDataIndication(..) , Cookie(..) , CertificateAuthorities(..) ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Network.TLS.Struct ( DistinguishedName , ExtensionID , EnumSafe8(..) , EnumSafe16(..) , HashAndSignatureAlgorithm ) import Network.TLS.Crypto.Types import Network.TLS.Types (Version(..), HostName) import Network.TLS.Wire import Network.TLS.Imports import Network.TLS.Packet ( putDNames , getDNames , putSignatureHashAlgorithm , getSignatureHashAlgorithm , putBinaryVersion , getBinaryVersion ) ------------------------------------------------------------ -- central list defined in extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ClientCertificateUrl , extensionID_TrustedCAKeys , extensionID_TruncatedHMAC , extensionID_StatusRequest , extensionID_UserMapping , extensionID_ClientAuthz , extensionID_ServerAuthz , extensionID_CertType , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SRP , extensionID_SignatureAlgorithms , extensionID_SRTP , extensionID_Heartbeat , extensionID_ApplicationLayerProtocolNegotiation , extensionID_StatusRequestv2 , extensionID_SignedCertificateTimestamp , extensionID_ClientCertificateType , extensionID_ServerCertificateType , extensionID_Padding , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket , extensionID_PreSharedKey , extensionID_EarlyData , extensionID_SupportedVersions , extensionID_Cookie , extensionID_PskKeyExchangeModes , extensionID_CertificateAuthorities , extensionID_OidFilters , extensionID_PostHandshakeAuth , extensionID_SignatureAlgorithmsCert , extensionID_KeyShare , extensionID_SecureRenegotiation :: ExtensionID extensionID_ServerName = 0x0 -- RFC6066 extensionID_MaxFragmentLength = 0x1 -- RFC6066 extensionID_ClientCertificateUrl = 0x2 -- RFC6066 extensionID_TrustedCAKeys = 0x3 -- RFC6066 extensionID_TruncatedHMAC = 0x4 -- RFC6066 extensionID_StatusRequest = 0x5 -- RFC6066 extensionID_UserMapping = 0x6 -- RFC4681 extensionID_ClientAuthz = 0x7 -- RFC5878 extensionID_ServerAuthz = 0x8 -- RFC5878 extensionID_CertType = 0x9 -- RFC6091 extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3 extensionID_EcPointFormats = 0xb -- RFC4492 extensionID_SRP = 0xc -- RFC5054 extensionID_SignatureAlgorithms = 0xd -- RFC5246, TLS 1.3 extensionID_SRTP = 0xe -- RFC5764 extensionID_Heartbeat = 0xf -- RFC6520 extensionID_ApplicationLayerProtocolNegotiation = 0x10 -- RFC7301 extensionID_StatusRequestv2 = 0x11 -- RFC6961 extensionID_SignedCertificateTimestamp = 0x12 -- RFC6962 extensionID_ClientCertificateType = 0x13 -- RFC7250 extensionID_ServerCertificateType = 0x14 -- RFC7250 extensionID_Padding = 0x15 -- draft-agl-tls-padding. expires 2015-03-12 extensionID_EncryptThenMAC = 0x16 -- RFC7366 extensionID_ExtendedMasterSecret = 0x17 -- REF7627 extensionID_SessionTicket = 0x23 -- RFC4507 -- Reserved 0x28 -- TLS 1.3 extensionID_PreSharedKey = 0x29 -- TLS 1.3 extensionID_EarlyData = 0x2a -- TLS 1.3 extensionID_SupportedVersions = 0x2b -- TLS 1.3 extensionID_Cookie = 0x2c -- TLS 1.3 extensionID_PskKeyExchangeModes = 0x2d -- TLS 1.3 -- Reserved 0x2e -- TLS 1.3 extensionID_CertificateAuthorities = 0x2f -- TLS 1.3 extensionID_OidFilters = 0x30 -- TLS 1.3 extensionID_PostHandshakeAuth = 0x31 -- TLS 1.3 extensionID_SignatureAlgorithmsCert = 0x32 -- TLS 1.3 extensionID_KeyShare = 0x33 -- TLS 1.3 extensionID_SecureRenegotiation = 0xff01 -- RFC5746 ------------------------------------------------------------ definedExtensions :: [ExtensionID] definedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ClientCertificateUrl , extensionID_TrustedCAKeys , extensionID_TruncatedHMAC , extensionID_StatusRequest , extensionID_UserMapping , extensionID_ClientAuthz , extensionID_ServerAuthz , extensionID_CertType , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SRP , extensionID_SignatureAlgorithms , extensionID_SRTP , extensionID_Heartbeat , extensionID_ApplicationLayerProtocolNegotiation , extensionID_StatusRequestv2 , extensionID_SignedCertificateTimestamp , extensionID_ClientCertificateType , extensionID_ServerCertificateType , extensionID_Padding , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket , extensionID_PreSharedKey , extensionID_EarlyData , extensionID_SupportedVersions , extensionID_Cookie , extensionID_PskKeyExchangeModes , extensionID_KeyShare , extensionID_SignatureAlgorithmsCert , extensionID_CertificateAuthorities , extensionID_SecureRenegotiation ] -- | all supported extensions by the implementation supportedExtensions :: [ExtensionID] supportedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ApplicationLayerProtocolNegotiation , extensionID_ExtendedMasterSecret , extensionID_SecureRenegotiation , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SignatureAlgorithms , extensionID_SignatureAlgorithmsCert , extensionID_KeyShare , extensionID_PreSharedKey , extensionID_EarlyData , extensionID_SupportedVersions , extensionID_Cookie , extensionID_PskKeyExchangeModes , extensionID_CertificateAuthorities ] ------------------------------------------------------------ data MessageType = MsgTClientHello | MsgTServerHello | MsgTHelloRetryRequest | MsgTEncryptedExtensions | MsgTNewSessionTicket | MsgTCertificateRequest deriving (Eq,Show) -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID extensionDecode :: MessageType -> ByteString -> Maybe a extensionEncode :: a -> ByteString ------------------------------------------------------------ -- | Server Name extension including the name type and the associated name. -- the associated name decoding is dependant of its name type. -- name type = 0 : hostname newtype ServerName = ServerName [ServerNameType] deriving (Show,Eq) data ServerNameType = ServerNameHostName HostName | ServerNameOther (Word8, ByteString) deriving (Show,Eq) instance Extension ServerName where extensionID _ = extensionID_ServerName extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque extensionDecode MsgTClientHello = decodeServerName extensionDecode MsgTServerHello = decodeServerName extensionDecode MsgTEncryptedExtensions = decodeServerName extensionDecode _ = error "extensionDecode: ServerName" decodeServerName :: ByteString -> Maybe ServerName decodeServerName = runGetMaybe $ do len <- fromIntegral <$> getWord16 ServerName <$> getList len getServerName where getServerName = do ty <- getWord8 snameParsed <- getOpaque16 let !sname = B.copy snameParsed name = case ty of 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion _ -> ServerNameOther (ty, sname) return (1+2+B.length sname, name) ------------------------------------------------------------ -- | Max fragment extension with length from 512 bytes to 4096 bytes -- -- RFC 6066 defines: -- If a server receives a maximum fragment length negotiation request -- for a value other than the allowed values, it MUST abort the -- handshake with an "illegal_parameter" alert. -- -- So, if a server receives MaxFragmentLengthOther, it must send the alert. data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum | MaxFragmentLengthOther Word8 deriving (Show,Eq) data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096 deriving (Show,Eq) instance Extension MaxFragmentLength where extensionID _ = extensionID_MaxFragmentLength extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l where fromMaxFragmentEnum MaxFragment512 = 1 fromMaxFragmentEnum MaxFragment1024 = 2 fromMaxFragmentEnum MaxFragment2048 = 3 fromMaxFragmentEnum MaxFragment4096 = 4 extensionEncode (MaxFragmentLengthOther l) = runPut $ putWord8 l extensionDecode MsgTClientHello = decodeMaxFragmentLength extensionDecode MsgTServerHello = decodeMaxFragmentLength extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength extensionDecode _ = error "extensionDecode: MaxFragmentLength" decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8 where toMaxFragmentEnum 1 = MaxFragmentLength MaxFragment512 toMaxFragmentEnum 2 = MaxFragmentLength MaxFragment1024 toMaxFragmentEnum 3 = MaxFragmentLength MaxFragment2048 toMaxFragmentEnum 4 = MaxFragmentLength MaxFragment4096 toMaxFragmentEnum n = MaxFragmentLengthOther n ------------------------------------------------------------ -- | Secure Renegotiation data SecureRenegotiation = SecureRenegotiation ByteString (Maybe ByteString) deriving (Show,Eq) instance Extension SecureRenegotiation where extensionID _ = extensionID_SecureRenegotiation extensionEncode (SecureRenegotiation cvd svd) = runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty svd) extensionDecode msgtype = runGetMaybe $ do opaque <- getOpaque8 case msgtype of MsgTServerHello -> let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque in return $ SecureRenegotiation cvd (Just svd) MsgTClientHello -> return $ SecureRenegotiation opaque Nothing _ -> error "extensionDecode: SecureRenegotiation" ------------------------------------------------------------ -- | Application Layer Protocol Negotiation (ALPN) newtype ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension ApplicationLayerProtocolNegotiation where extensionID _ = extensionID_ApplicationLayerProtocolNegotiation extensionEncode (ApplicationLayerProtocolNegotiation bytes) = runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation" decodeApplicationLayerProtocolNegotiation :: ByteString -> Maybe ApplicationLayerProtocolNegotiation decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do len <- getWord16 ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN where getALPN = do alpnParsed <- getOpaque8 let !alpn = B.copy alpnParsed return (B.length alpn + 1, alpn) ------------------------------------------------------------ -- | Extended Master Secret data ExtendedMasterSecret = ExtendedMasterSecret deriving (Show,Eq) instance Extension ExtendedMasterSecret where extensionID _ = extensionID_ExtendedMasterSecret extensionEncode ExtendedMasterSecret = B.empty extensionDecode MsgTClientHello _ = Just ExtendedMasterSecret extensionDecode MsgTServerHello _ = Just ExtendedMasterSecret extensionDecode _ _ = error "extensionDecode: ExtendedMasterSecret" ------------------------------------------------------------ newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) -- on decode, filter all unknown curves instance Extension NegotiatedGroups where extensionID _ = extensionID_NegotiatedGroups extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups extensionDecode MsgTClientHello = decodeNegotiatedGroups extensionDecode MsgTEncryptedExtensions = decodeNegotiatedGroups extensionDecode _ = error "extensionDecode: NegotiatedGroups" decodeNegotiatedGroups :: ByteString -> Maybe NegotiatedGroups decodeNegotiatedGroups = runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16) ------------------------------------------------------------ newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) data EcPointFormat = EcPointFormat_Uncompressed | EcPointFormat_AnsiX962_compressed_prime | EcPointFormat_AnsiX962_compressed_char2 deriving (Show,Eq) instance EnumSafe8 EcPointFormat where fromEnumSafe8 EcPointFormat_Uncompressed = 0 fromEnumSafe8 EcPointFormat_AnsiX962_compressed_prime = 1 fromEnumSafe8 EcPointFormat_AnsiX962_compressed_char2 = 2 toEnumSafe8 0 = Just EcPointFormat_Uncompressed toEnumSafe8 1 = Just EcPointFormat_AnsiX962_compressed_prime toEnumSafe8 2 = Just EcPointFormat_AnsiX962_compressed_char2 toEnumSafe8 _ = Nothing -- on decode, filter all unknown formats instance Extension EcPointFormatsSupported where extensionID _ = extensionID_EcPointFormats extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats extensionDecode MsgTClientHello = decodeEcPointFormatsSupported extensionDecode MsgTServerHello = decodeEcPointFormatsSupported extensionDecode _ = error "extensionDecode: EcPointFormatsSupported" decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported decodeEcPointFormatsSupported = runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8) ------------------------------------------------------------ -- Fixme: this is incomplete -- newtype SessionTicket = SessionTicket ByteString data SessionTicket = SessionTicket deriving (Show,Eq) instance Extension SessionTicket where extensionID _ = extensionID_SessionTicket extensionEncode SessionTicket{} = runPut $ return () extensionDecode MsgTClientHello = runGetMaybe (return SessionTicket) extensionDecode MsgTServerHello = runGetMaybe (return SessionTicket) extensionDecode _ = error "extensionDecode: SessionTicket" ------------------------------------------------------------ newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq) data HeartBeatMode = HeartBeat_PeerAllowedToSend | HeartBeat_PeerNotAllowedToSend deriving (Show,Eq) instance EnumSafe8 HeartBeatMode where fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1 fromEnumSafe8 HeartBeat_PeerNotAllowedToSend = 2 toEnumSafe8 1 = Just HeartBeat_PeerAllowedToSend toEnumSafe8 2 = Just HeartBeat_PeerNotAllowedToSend toEnumSafe8 _ = Nothing instance Extension HeartBeat where extensionID _ = extensionID_Heartbeat extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 mode extensionDecode MsgTClientHello = decodeHeartBeat extensionDecode MsgTServerHello = decodeHeartBeat extensionDecode _ = error "extensionDecode: HeartBeat" decodeHeartBeat :: ByteString -> Maybe HeartBeat decodeHeartBeat = runGetMaybe $ do mm <- toEnumSafe8 <$> getWord8 case mm of Just m -> return $ HeartBeat m Nothing -> fail "unknown HeartBeatMode" ------------------------------------------------------------ newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq) instance Extension SignatureAlgorithms where extensionID _ = extensionID_SignatureAlgorithms extensionEncode (SignatureAlgorithms algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) >> mapM_ putSignatureHashAlgorithm algs extensionDecode MsgTClientHello = decodeSignatureAlgorithms extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms extensionDecode _ = error "extensionDecode: SignatureAlgorithms" decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms decodeSignatureAlgorithms = runGetMaybe $ do len <- getWord16 SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) ------------------------------------------------------------ data PostHandshakeAuth = PostHandshakeAuth deriving (Show,Eq) instance Extension PostHandshakeAuth where extensionID _ = extensionID_PostHandshakeAuth extensionEncode _ = B.empty extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth extensionDecode _ = error "extensionDecode: PostHandshakeAuth" ------------------------------------------------------------ newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] deriving (Show,Eq) instance Extension SignatureAlgorithmsCert where extensionID _ = extensionID_SignatureAlgorithmsCert extensionEncode (SignatureAlgorithmsCert algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) >> mapM_ putSignatureHashAlgorithm algs extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert" decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert decodeSignatureAlgorithmsCert = runGetMaybe $ do len <- getWord16 SignatureAlgorithmsCert <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) ------------------------------------------------------------ data SupportedVersions = SupportedVersionsClientHello [Version] | SupportedVersionsServerHello Version deriving (Show,Eq) instance Extension SupportedVersions where extensionID _ = extensionID_SupportedVersions extensionEncode (SupportedVersionsClientHello vers) = runPut $ do putWord8 (fromIntegral (length vers * 2)) mapM_ putBinaryVersion vers extensionEncode (SupportedVersionsServerHello ver) = runPut $ putBinaryVersion ver extensionDecode MsgTClientHello = runGetMaybe $ do len <- fromIntegral <$> getWord8 SupportedVersionsClientHello . catMaybes <$> getList len getVer where getVer = do ver <- getBinaryVersion return (2,ver) extensionDecode MsgTServerHello = runGetMaybe $ do mver <- getBinaryVersion case mver of Just ver -> return $ SupportedVersionsServerHello ver Nothing -> fail "extensionDecode: SupportedVersionsServerHello" extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello" ------------------------------------------------------------ data KeyShareEntry = KeyShareEntry { keyShareEntryGroup :: Group , keySHareEntryKeyExchange:: ByteString } deriving (Show,Eq) getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) getKeyShareEntry = do g <- getWord16 l <- fromIntegral <$> getWord16 key <- getBytes l let !len = l + 4 case toEnumSafe16 g of Nothing -> return (len, Nothing) Just grp -> return (len, Just $ KeyShareEntry grp key) putKeyShareEntry :: KeyShareEntry -> Put putKeyShareEntry (KeyShareEntry grp key) = do putWord16 $ fromEnumSafe16 grp putWord16 $ fromIntegral $ B.length key putBytes key data KeyShare = KeyShareClientHello [KeyShareEntry] | KeyShareServerHello KeyShareEntry | KeyShareHRR Group deriving (Show,Eq) instance Extension KeyShare where extensionID _ = extensionID_KeyShare extensionEncode (KeyShareClientHello kses) = runPut $ do let !len = sum [B.length key + 4 | KeyShareEntry _ key <- kses] putWord16 $ fromIntegral len mapM_ putKeyShareEntry kses extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse extensionEncode (KeyShareHRR grp) = runPut $ putWord16 $ fromEnumSafe16 grp extensionDecode MsgTServerHello = runGetMaybe $ do (_, ment) <- getKeyShareEntry case ment of Nothing -> fail "decoding KeyShare for ServerHello" Just ent -> return $ KeyShareServerHello ent extensionDecode MsgTClientHello = runGetMaybe $ do len <- fromIntegral <$> getWord16 grps <- getList len getKeyShareEntry return $ KeyShareClientHello $ catMaybes grps extensionDecode MsgTHelloRetryRequest = runGetMaybe $ do mgrp <- toEnumSafe16 <$> getWord16 case mgrp of Nothing -> fail "decoding KeyShare for HRR" Just grp -> return $ KeyShareHRR grp extensionDecode _ = error "extensionDecode: KeyShare" ------------------------------------------------------------ data PskKexMode = PSK_KE | PSK_DHE_KE deriving (Eq, Show) instance EnumSafe8 PskKexMode where fromEnumSafe8 PSK_KE = 0 fromEnumSafe8 PSK_DHE_KE = 1 toEnumSafe8 0 = Just PSK_KE toEnumSafe8 1 = Just PSK_DHE_KE toEnumSafe8 _ = Nothing newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode] deriving (Eq, Show) instance Extension PskKeyExchangeModes where extensionID _ = extensionID_PskKeyExchangeModes extensionEncode (PskKeyExchangeModes pkms) = runPut $ putWords8 $ map fromEnumSafe8 pkms extensionDecode MsgTClientHello = runGetMaybe $ PskKeyExchangeModes . mapMaybe toEnumSafe8 <$> getWords8 extensionDecode _ = error "extensionDecode: PskKeyExchangeModes" ------------------------------------------------------------ data PskIdentity = PskIdentity ByteString Word32 deriving (Eq, Show) data PreSharedKey = PreSharedKeyClientHello [PskIdentity] [ByteString] | PreSharedKeyServerHello Int deriving (Eq, Show) instance Extension PreSharedKey where extensionID _ = extensionID_PreSharedKey extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do putOpaque16 $ runPut (mapM_ putIdentity ids) putOpaque16 $ runPut (mapM_ putBinder bds) where putIdentity (PskIdentity bs w) = do putOpaque16 bs putWord32 w putBinder = putOpaque8 extensionEncode (PreSharedKeyServerHello w16) = runPut $ putWord16 $ fromIntegral w16 extensionDecode MsgTServerHello = runGetMaybe $ PreSharedKeyServerHello . fromIntegral <$> getWord16 extensionDecode MsgTClientHello = runGetMaybe $ do len1 <- fromIntegral <$> getWord16 identities <- getList len1 getIdentity len2 <- fromIntegral <$> getWord16 binders <- getList len2 getBinder return $ PreSharedKeyClientHello identities binders where getIdentity = do identity <- getOpaque16 age <- getWord32 let len = 2 + B.length identity + 4 return (len, PskIdentity identity age) getBinder = do l <- fromIntegral <$> getWord8 binder <- getBytes l let len = l + 1 return (len, binder) extensionDecode _ = error "extensionDecode: PreShareKey" ------------------------------------------------------------ newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32) deriving (Eq, Show) instance Extension EarlyDataIndication where extensionID _ = extensionID_EarlyData extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32 extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing) extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing) extensionDecode MsgTNewSessionTicket = runGetMaybe $ EarlyDataIndication . Just <$> getWord32 extensionDecode _ = error "extensionDecode: EarlyDataIndication" ------------------------------------------------------------ newtype Cookie = Cookie ByteString deriving (Eq, Show) instance Extension Cookie where extensionID _ = extensionID_Cookie extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16) extensionDecode _ = error "extensionDecode: Cookie" ------------------------------------------------------------ newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName] deriving (Eq, Show) instance Extension CertificateAuthorities where extensionID _ = extensionID_CertificateAuthorities extensionEncode (CertificateAuthorities names) = runPut $ putDNames names extensionDecode MsgTClientHello = runGetMaybe (CertificateAuthorities <$> getDNames) extensionDecode MsgTCertificateRequest = runGetMaybe (CertificateAuthorities <$> getDNames) extensionDecode _ = error "extensionDecode: CertificateAuthorities" tls-1.5.4/Network/TLS/Context.hs0000644000000000000000000001633113623162342014572 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Context -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Context ( -- * Context configuration TLSParams -- * Context object and accessor , Context(..) , Hooks(..) , Established(..) , ctxEOF , ctxHasSSLv2ClientHello , ctxDisableSSLv2ClientHello , ctxEstablished , withLog , ctxWithHooks , contextModifyHooks , setEOF , setEstablished , contextFlush , contextClose , contextSend , contextRecv , updateMeasure , withMeasure , withReadLock , withWriteLock , withStateLock , withRWLock -- * information , Information(..) , contextGetInformation -- * New contexts , contextNew -- * Deprecated new contexts methods , contextNewOnHandle #ifdef INCLUDE_NETWORK , contextNewOnSocket #endif -- * Context hooks , contextHookSetHandshakeRecv , contextHookSetHandshake13Recv , contextHookSetCertificateRecv , contextHookSetLogging -- * Using context states , throwCore , usingState , usingState_ , runTxState , runRxState , usingHState , getHState , getStateRNG , tls13orLater ) where import Network.TLS.Backend import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.State import Network.TLS.Hooks import Network.TLS.Record.State import Network.TLS.Parameters import Network.TLS.Measurement import Network.TLS.Types (Role(..)) import Network.TLS.Handshake (handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith) import Network.TLS.PostHandshake (requestCertificateServer, postHandshakeAuthClientWith, postHandshakeAuthServerWith) import Network.TLS.X509 import Network.TLS.RNG import Control.Concurrent.MVar import Control.Monad.State.Strict import Data.IORef -- deprecated imports #ifdef INCLUDE_NETWORK import Network.Socket (Socket) #endif import System.IO (Handle) 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 stvar <- newMVar st eof <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement -- we enable the reception of SSLv2 ClientHello message only in the -- server context, where we might be dealing with an old/compat client. sslv2Compat <- newIORef (role == ServerRole) needEmptyPacket <- newIORef False hooks <- newIORef defaultHooks tx <- newMVar newRecordState rx <- newMVar newRecordState hs <- newMVar Nothing as <- newIORef [] crs <- newIORef [] lockWrite <- newMVar () lockRead <- newMVar () lockState <- newMVar () return Context { ctxConnection = getBackend backend , ctxShared = shared , ctxSupported = supported , ctxState = stvar , ctxTxState = tx , ctxRxState = rx , ctxHandshake = hs , ctxDoHandshake = doHandshake params , ctxDoHandshakeWith = doHandshakeWith params , ctxDoRequestCertificate = doRequestCertificate params , ctxDoPostHandshakeAuthWith = doPostHandshakeAuthWith params , ctxMeasurement = stats , ctxEOF_ = eof , ctxEstablished_ = established , ctxSSLv2ClientHello = sslv2Compat , ctxNeedEmptyPacket = needEmptyPacket , ctxHooks = hooks , ctxLockWrite = lockWrite , ctxLockRead = lockRead , ctxLockState = lockState , ctxPendingActions = as , ctxCertRequests = crs , ctxKeyLogger = debugKeyLogger debug } -- | create a new context on an handle. contextNewOnHandle :: (MonadIO m, TLSParams params) => Handle -- ^ Handle of the connection. -> params -- ^ Parameters of the context. -> m Context contextNewOnHandle = contextNew {-# DEPRECATED contextNewOnHandle "use contextNew" #-} #ifdef INCLUDE_NETWORK -- | create a new context on a socket. contextNewOnSocket :: (MonadIO m, TLSParams params) => Socket -- ^ Socket of the connection. -> params -- ^ Parameters of the context. -> m Context contextNewOnSocket sock params = contextNew sock params {-# DEPRECATED contextNewOnSocket "use contextNew" #-} #endif contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f = contextModifyHooks context (\hooks -> hooks { hookRecvHandshake = f }) 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 }) tls-1.5.4/Network/TLS/Crypto.hs0000644000000000000000000003230713623162342014427 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} 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 , KxError(..) , RSAEncoding(..) ) where import qualified Crypto.Hash as H import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) import Crypto.Error import Crypto.Number.Basic (numBits) import Crypto.Random import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA 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 qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..)) import Data.X509.EC (ecPubKeyCurveName, unserializePoint) import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types import Network.TLS.Imports import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding (DER(..), BER(..)) {-# 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_DSS (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_DSS (PubKeyEC _, PrivKeyEC _) -> Just KX_ECDSA (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just KX_ECDSA (PubKeyEd448 _, PrivKeyEd448 _) -> Just KX_ECDSA _ -> Nothing findFiniteFieldGroup :: DH.Params -> Maybe Group findFiniteFieldGroup params = lookup (pg params) table where pg (DH.Params p g _) = (p, g) table = [ (pg prms, grp) | grp <- availableFFGroups , let Just prms = dhParamsForGroup grp ] 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 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 | DSSParams | 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) DSSParams 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 $ do -- get the curve name and the public key data let pubBS = pubkeyEC_pub key curveName <- ecPubKeyCurveName key -- decode the signature signature <- case decodeASN1' BER sigBS of Left _ -> Nothing Right [Start Sequence,IntVal r,IntVal s,End Sequence] -> Just $ ECDSA.Signature r s Right _ -> Nothing -- decode the public key related to the curve let curve = ECC.getCurveByName curveName pubkey <- ECDSA.PublicKey curve <$> unserializePoint curve pubBS verifyF <- case alg of MD5 -> Just (ECDSA.verify H.MD5) SHA1 -> Just (ECDSA.verify H.SHA1) SHA224 -> Just (ECDSA.verify H.SHA224) SHA256 -> Just (ECDSA.verify H.SHA256) SHA384 -> Just (ECDSA.verify H.SHA384) SHA512 -> Just (ECDSA.verify H.SHA512) _ -> Nothing return $ verifyF pubkey signature msg 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 _) DSSParams 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 (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 tls-1.5.4/Network/TLS/Cipher.hs0000644000000000000000000001047113623162342014357 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Network.TLS.Cipher -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Cipher ( CipherKeyExchangeType(..) , Bulk(..) , BulkFunctions(..) , BulkDirection(..) , BulkState(..) , BulkStream(..) , BulkBlock , BulkAEAD , bulkInit , Hash(..) , Cipher(..) , CipherID , cipherKeyBlockSize , BulkKey , BulkIV , BulkNonce , BulkAdditionalData , cipherAllowedForVersion , hasMAC , hasRecordIV ) where import Crypto.Cipher.Types (AuthTag) import Network.TLS.Types (CipherID, Version(..)) import Network.TLS.Crypto (Hash(..), hashDigestSize) import qualified Data.ByteString as B -- FIXME convert to newtype type BulkKey = B.ByteString type BulkIV = B.ByteString type BulkNonce = B.ByteString type BulkAdditionalData = B.ByteString data BulkState = BulkStateStream BulkStream | BulkStateBlock BulkBlock | BulkStateAEAD BulkAEAD | BulkStateUninitialized instance Show BulkState where show (BulkStateStream _) = "BulkStateStream" show (BulkStateBlock _) = "BulkStateBlock" show (BulkStateAEAD _) = "BulkStateAEAD" show BulkStateUninitialized = "BulkStateUninitialized" newtype BulkStream = BulkStream (B.ByteString -> (B.ByteString, BulkStream)) type BulkBlock = BulkIV -> B.ByteString -> (B.ByteString, BulkIV) type BulkAEAD = BulkNonce -> B.ByteString -> BulkAdditionalData -> (B.ByteString, AuthTag) data BulkDirection = BulkEncrypt | BulkDecrypt deriving (Show,Eq) 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) data BulkFunctions = BulkBlockF (BulkDirection -> BulkKey -> BulkBlock) | BulkStreamF (BulkDirection -> BulkKey -> BulkStream) | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD) hasMAC,hasRecordIV :: BulkFunctions -> Bool hasMAC (BulkBlockF _ ) = True hasMAC (BulkStreamF _) = True hasMAC (BulkAeadF _ ) = False hasRecordIV = hasMAC data CipherKeyExchangeType = CipherKeyExchange_RSA | CipherKeyExchange_DH_Anon | CipherKeyExchange_DHE_RSA | CipherKeyExchange_ECDHE_RSA | CipherKeyExchange_DHE_DSS | CipherKeyExchange_DH_DSS | CipherKeyExchange_DH_RSA | CipherKeyExchange_ECDH_ECDSA | CipherKeyExchange_ECDH_RSA | CipherKeyExchange_ECDHE_ECDSA | CipherKeyExchange_TLS13 -- not expressed in cipher suite deriving (Show,Eq) data Bulk = Bulk { bulkName :: String , bulkKeySize :: Int , bulkIVSize :: Int , bulkExplicitIV :: Int -- Explicit size for IV for AEAD Cipher, 0 otherwise , bulkAuthTagLen :: Int -- Authentication tag length in bytes for AEAD Cipher, 0 otherwise , bulkBlockSize :: Int , bulkF :: BulkFunctions } instance Show Bulk where show bulk = bulkName bulk instance Eq Bulk where b1 == b2 = and [ bulkName b1 == bulkName b2 , bulkKeySize b1 == bulkKeySize b2 , bulkIVSize b1 == bulkIVSize b2 , bulkBlockSize b1 == bulkBlockSize b2 ] -- | Cipher algorithm data Cipher = Cipher { cipherID :: CipherID , cipherName :: String , cipherHash :: Hash , cipherBulk :: Bulk , cipherKeyExchange :: CipherKeyExchangeType , cipherMinVer :: Maybe Version , cipherPRFHash :: Maybe Hash } cipherKeyBlockSize :: Cipher -> Int cipherKeyBlockSize cipher = 2 * (hashDigestSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk) where bulk = cipherBulk cipher -- | 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) instance Show Cipher where show c = cipherName c instance Eq Cipher where (==) c1 c2 = cipherID c1 == cipherID c2 tls-1.5.4/Network/TLS/Wire.hs0000644000000000000000000001206013623162342014047 0ustar0000000000000000-- | -- Module : Network.TLS.Wire -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Wire module is a specialized marshalling/unmarshalling package related to the TLS protocol. -- all multibytes values are written as big endian. -- module Network.TLS.Wire ( Get , GetResult(..) , GetContinuation , runGet , runGetErr , runGetMaybe , tryGet , remaining , getWord8 , getWords8 , getWord16 , getWords16 , getWord24 , getWord32 , getWord64 , getBytes , getOpaque8 , getOpaque16 , getOpaque24 , getInteger16 , getBigNum16 , getList , processBytes , isEmpty , Put , runPut , putWord8 , putWords8 , putWord16 , putWords16 , putWord24 , putWord32 , putWord64 , putBytes , putOpaque8 , putOpaque16 , putOpaque24 , putInteger16 , putBigNum16 , encodeWord16 , encodeWord32 , encodeWord64 ) where import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put import qualified Data.ByteString as B import Network.TLS.Struct import Network.TLS.Imports 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 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) 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-1.5.4/Network/TLS/MAC.hs0000644000000000000000000000515213623162342013545 0ustar0000000000000000-- | -- Module : Network.TLS.MAC -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.MAC ( macSSL , hmac , prf_MD5 , prf_SHA1 , prf_SHA256 , prf_TLS , prf_MD5SHA1 ) where import Network.TLS.Crypto import Network.TLS.Types import Network.TLS.Imports import qualified Data.ByteArray as B (xor) import qualified Data.ByteString as B 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-1.5.4/Network/TLS/State.hs0000644000000000000000000002504713623162342014232 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Network.TLS.State -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the State module contains calls related to state initialization/manipulation -- which is use by the Receiving module and the Sending module. -- module Network.TLS.State ( TLSState(..) , TLSSt , runTLSState , newTLSState , withTLSRNG , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial , certVerifyHandshakeTypeMaterial , certVerifyHandshakeMaterial , setVersion , setVersionIfUnset , getVersion , getVersionWithDefault , setSecureRenegotiation , getSecureRenegotiation , setExtensionALPN , getExtensionALPN , setNegotiatedProtocol , getNegotiatedProtocol , setClientALPNSuggest , getClientALPNSuggest , setClientEcPointFormatSuggest , getClientEcPointFormatSuggest , getClientCertificateChain , setClientCertificateChain , setClientSNI , getClientSNI , getVerifiedData , setSession , getSession , isSessionResuming , isClientContext , setExporterMasterSecret , getExporterMasterSecret , setTLS13KeyShare , getTLS13KeyShare , setTLS13PreSharedKey , getTLS13PreSharedKey , setTLS13HRR , getTLS13HRR , setTLS13Cookie , getTLS13Cookie , setClientSupportsPHA , getClientSupportsPHA -- * random , genRandom , withRNG ) where import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.RNG import Network.TLS.Types (Role(..), HostName) import Network.TLS.Wire (GetContinuation) import Network.TLS.Extension import qualified Data.ByteString as B import Control.Monad.State.Strict import Network.TLS.ErrT import Crypto.Random import Data.X509 (CertificateChain) data TLSState = TLSState { stSession :: Session , stSessionResuming :: Bool , stSecureRenegotiation :: Bool -- RFC 5746 , stClientVerifiedData :: ByteString -- RFC 5746 , stServerVerifiedData :: ByteString -- RFC 5746 , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, ByteString)) , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , stClientSNI :: Maybe HostName , stRandomGen :: StateRNG , stVersion :: Maybe Version , stClientContext :: Role , stTLS13KeyShare :: Maybe KeyShare , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: !Bool , stTLS13Cookie :: Maybe Cookie , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3 , stClientSupportsPHA :: !Bool -- Post-Handshake Authentication (TLS 1.3) } 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) #if MIN_VERSION_mtl(2,1,0) state f = TLSSt (lift $ state f) #endif runTLSState :: TLSSt a -> TLSState -> (Either TLSError a, TLSState) runTLSState f st = runState (runErrT (runTLSSt f)) st newTLSState :: StateRNG -> Role -> TLSState newTLSState rng clientContext = TLSState { stSession = Session Nothing , stSessionResuming = False , stSecureRenegotiation = False , stClientVerifiedData = B.empty , stServerVerifiedData = B.empty , stExtensionALPN = False , stHandshakeRecordCont = Nothing , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = Nothing , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing , stRandomGen = rng , stVersion = Nothing , stClientContext = clientContext , stTLS13KeyShare = Nothing , stTLS13PreSharedKey = Nothing , stTLS13HRR = False , stTLS13Cookie = Nothing , stExporterMasterSecret = Nothing , stClientSupportsPHA = False } updateVerifiedData :: Role -> ByteString -> TLSSt () updateVerifiedData sending bs = do cc <- isClientContext if cc /= sending then modify (\st -> st { stServerVerifiedData = bs }) else modify (\st -> st { stClientVerifiedData = bs }) finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello = True finishHandshakeTypeMaterial HandshakeType_ServerHello = True finishHandshakeTypeMaterial HandshakeType_Certificate = True finishHandshakeTypeMaterial HandshakeType_HelloRequest = False finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True finishHandshakeTypeMaterial HandshakeType_CertRequest = True finishHandshakeTypeMaterial HandshakeType_CertVerify = True finishHandshakeTypeMaterial HandshakeType_Finished = True finishHandshakeMaterial :: Handshake -> Bool finishHandshakeMaterial = finishHandshakeTypeMaterial . 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 certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake setSession :: Session -> Bool -> TLSSt () setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming }) getSession :: TLSSt Session getSession = gets stSession isSessionResuming :: TLSSt Bool isSessionResuming = gets stSessionResuming 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 setClientSNI :: HostName -> TLSSt () setClientSNI hn = modify (\st -> st { stClientSNI = Just hn }) getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI getVerifiedData :: Role -> TLSSt ByteString getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) isClientContext :: TLSSt Role isClientContext = 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 setExporterMasterSecret :: ByteString -> TLSSt () setExporterMasterSecret key = modify (\st -> st { stExporterMasterSecret = Just key }) getExporterMasterSecret :: TLSSt (Maybe ByteString) getExporterMasterSecret = gets stExporterMasterSecret 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 setClientSupportsPHA :: Bool -> TLSSt () setClientSupportsPHA b = modify (\st -> st { stClientSupportsPHA = b }) getClientSupportsPHA :: TLSSt Bool getClientSupportsPHA = gets stClientSupportsPHA tls-1.5.4/Network/TLS/Struct.hs0000644000000000000000000005621713623162342014441 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} -- | -- Module : Network.TLS.Struct -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Struct module contains all definitions and values of the TLS protocol -- {-# LANGUAGE CPP #-} module Network.TLS.Struct ( Version(..) , ConnectionEnd(..) , CipherType(..) , CipherData(..) , ExtensionID , ExtensionRaw(..) , CertificateType(..) , lastSupportedCertificateType , HashAlgorithm(..) , SignatureAlgorithm(..) , HashAndSignatureAlgorithm , DigitallySigned(..) , Signature , ProtocolType(..) , TLSError(..) , TLSException(..) , DistinguishedName , BigNum(..) , bigNumToInteger , bigNumFromInteger , ServerDHParams(..) , serverDHParamsToParams , serverDHParamsToPublic , serverDHParamsFrom , ServerECDHParams(..) , ServerRSAParams(..) , ServerKeyXchgAlgorithmData(..) , ClientKeyXchgAlgorithmData(..) , Packet(..) , Header(..) , ServerRandom(..) , ClientRandom(..) , FinishedData , SessionID , Session(..) , SessionData(..) , AlertLevel(..) , AlertDescription(..) , HandshakeType(..) , Handshake(..) , numericalVer , verOfNum , TypeValuable, valOfType, valToType , EnumSafe8(..) , EnumSafe16(..) , packetType , typeOfHandshake ) where import Data.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Exception (Exception(..)) import Network.TLS.Types import Network.TLS.Crypto import Network.TLS.Util.Serialization import Network.TLS.Imports #if MIN_VERSION_mtl(2,2,1) #else import Control.Monad.Error #endif data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD 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. -- data CertificateType = CertificateType_RSA_Sign -- ^ TLS10 and up, RFC5246 | CertificateType_DSS_Sign -- ^ TLS10 and up, RFC5246 | CertificateType_ECDSA_Sign -- ^ TLS10 and up, RFC8422 | CertificateType_Ed25519_Sign -- ^ TLS13 and up, synthetic | CertificateType_Ed448_Sign -- ^ TLS13 and up, synthetic -- | None of the below will ever be presented to the callback. Any future -- public key algorithms valid for client certificates go above this line. | CertificateType_RSA_Fixed_DH -- Obsolete, unsupported | CertificateType_DSS_Fixed_DH -- Obsolete, unsupported | CertificateType_RSA_Ephemeral_DH -- Obsolete, unsupported | CertificateType_DSS_Ephemeral_DH -- Obsolete, unsupported | CertificateType_fortezza_dms -- Obsolete, unsupported | CertificateType_RSA_Fixed_ECDH -- Obsolete, unsupported | CertificateType_ECDSA_Fixed_ECDH -- Obsolete, unsupported | CertificateType_Unknown Word8 -- Obsolete, unsupported deriving (Eq, Ord, Show) -- | 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_DSS_Sign data HashAlgorithm = HashNone | HashMD5 | HashSHA1 | HashSHA224 | HashSHA256 | HashSHA384 | HashSHA512 | HashIntrinsic | HashOther Word8 deriving (Show,Eq) data SignatureAlgorithm = SignatureAnonymous | SignatureRSA | SignatureDSS | SignatureECDSA | SignatureRSApssRSAeSHA256 | SignatureRSApssRSAeSHA384 | SignatureRSApssRSAeSHA512 | SignatureEd25519 | SignatureEd448 | SignatureRSApsspssSHA256 | SignatureRSApsspssSHA384 | SignatureRSApsspssSHA512 | SignatureOther Word8 deriving (Show,Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) ------------------------------------------------------------ type Signature = ByteString data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature deriving (Show,Eq) data ProtocolType = ProtocolType_ChangeCipherSpec | ProtocolType_Alert | ProtocolType_Handshake | ProtocolType_AppData | ProtocolType_DeprecatedHandshake deriving (Eq, Show) -- | TLSError that might be returned through the TLS stack data TLSError = Error_Misc String -- ^ mainly for instance of Error | Error_Protocol (String, Bool, AlertDescription) | Error_Certificate String | Error_HandshakePolicy String -- ^ handshake policy failed. | Error_EOF | Error_Packet String | Error_Packet_unexpected String String | Error_Packet_Parsing String deriving (Eq, Show, Typeable) #if MIN_VERSION_mtl(2,2,1) #else instance Error TLSError where noMsg = Error_Misc "" strMsg = Error_Misc #endif instance Exception TLSError -- | TLS Exceptions related to bad user usage or -- asynchronous errors data TLSException = Terminated Bool String TLSError -- ^ Early termination exception with the reason -- and the error associated | HandshakeFailed TLSError -- ^ Handshake failed for the reason attached | ConnectionNotEstablished -- ^ Usage error when the connection has not been established -- and the user is trying to send or receive data deriving (Show,Eq,Typeable) instance Exception TLSException data Packet = Handshake [Handshake] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Show,Eq) data Header = Header ProtocolType Version Word16 deriving (Show,Eq) newtype ServerRandom = ServerRandom { unServerRandom :: ByteString } deriving (Show, Eq) newtype ClientRandom = ClientRandom { unClientRandom :: ByteString } deriving (Show, Eq) newtype Session = Session (Maybe SessionID) deriving (Show, Eq) type FinishedData = ByteString type ExtensionID = Word16 data ExtensionRaw = ExtensionRaw ExtensionID ByteString deriving (Eq) instance Show ExtensionRaw where show (ExtensionRaw eid bs) = "ExtensionRaw " ++ showEID eid ++ " " ++ showBytesHex bs showEID :: ExtensionID -> String showEID 0x0 = "ServerName" showEID 0x1 = "MaxFragmentLength" showEID 0x2 = "ClientCertificateUrl" showEID 0x3 = "TrustedCAKeys" showEID 0x4 = "TruncatedHMAC" showEID 0x5 = "StatusRequest" showEID 0x6 = "UserMapping" showEID 0x7 = "ClientAuthz" showEID 0x8 = "ServerAuthz" showEID 0x9 = "CertType" showEID 0xa = "NegotiatedGroups" showEID 0xb = "EcPointFormats" showEID 0xc = "SRP" showEID 0xd = "SignatureAlgorithm" showEID 0xe = "SRTP" showEID 0xf = "Heartbeat" showEID 0x10 = "ApplicationLayerProtocolNegotiation" showEID 0x11 = "StatusRequestv2" showEID 0x12 = "SignedCertificateTimestamp" showEID 0x13 = "ClientCertificateType" showEID 0x14 = "ServerCertificateType" showEID 0x15 = "Padding" showEID 0x16 = "EncryptThenMAC" showEID 0x17 = "ExtendedMasterSecret" showEID 0x23 = "SessionTicket" showEID 0x29 = "PreShardeKey" showEID 0x2a = "EarlyData" showEID 0x2b = "SupportedVersions" showEID 0x2c = "Cookie" showEID 0x2d = "PskKeyExchangeModes" showEID 0x2f = "CertificateAuthorities" showEID 0x30 = "OidFilters" showEID 0x31 = "PostHandshakeAuth" showEID 0x32 = "SignatureAlgorithmsCert" showEID 0x33 = "KeyShare" showEID 0xff01 = "SecureRenegotiation" showEID 0xffa5 = "QuicTransportParameters" showEID x = show x data AlertLevel = AlertLevel_Warning | AlertLevel_Fatal deriving (Show,Eq) data AlertDescription = CloseNotify | UnexpectedMessage | BadRecordMac | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation | RecordOverflow | DecompressionFailure | HandshakeFailure | BadCertificate | UnsupportedCertificate | CertificateRevoked | CertificateExpired | CertificateUnknown | IllegalParameter | UnknownCa | AccessDenied | DecodeError | DecryptError | ExportRestriction | ProtocolVersion | InsufficientSecurity | InternalError | InappropriateFallback -- RFC7507 | UserCanceled | NoRenegotiation | MissingExtension | UnsupportedExtension | CertificateUnobtainable | UnrecognizedName | BadCertificateStatusResponse | BadCertificateHashValue | UnknownPskIdentity | CertificateRequired | NoApplicationProtocol -- RFC7301 deriving (Show,Eq) data HandshakeType = HandshakeType_HelloRequest | HandshakeType_ClientHello | HandshakeType_ServerHello | HandshakeType_Certificate | HandshakeType_ServerKeyXchg | HandshakeType_CertRequest | HandshakeType_ServerHelloDone | HandshakeType_CertVerify | HandshakeType_ClientKeyXchg | HandshakeType_Finished deriving (Show,Eq) newtype BigNum = BigNum ByteString deriving (Show,Eq) bigNumToInteger :: BigNum -> Integer bigNumToInteger (BigNum b) = os2ip b bigNumFromInteger :: Integer -> BigNum bigNumFromInteger i = BigNum $ i2osp i data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum , 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 ServerKeyXchgAlgorithmData = SKX_DH_Anon ServerDHParams | SKX_DHE_DSS ServerDHParams DigitallySigned | SKX_DHE_RSA ServerDHParams DigitallySigned | SKX_ECDHE_RSA ServerECDHParams DigitallySigned | SKX_ECDHE_ECDSA ServerECDHParams DigitallySigned | SKX_RSA (Maybe ServerRSAParams) | SKX_DH_DSS (Maybe ServerRSAParams) | SKX_DH_RSA (Maybe ServerRSAParams) | SKX_Unparsed ByteString -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. | SKX_Unknown ByteString deriving (Show,Eq) data ClientKeyXchgAlgorithmData = CKX_RSA ByteString | CKX_DH DHPublic | CKX_ECDH ByteString deriving (Show,Eq) type DeprecatedRecord = ByteString data Handshake = ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] | Certificates CertificateChain | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName] | CertVerify DigitallySigned | Finished FinishedData deriving (Show,Eq) 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 Certificates{} = HandshakeType_Certificate typeOfHandshake HelloRequest = HandshakeType_HelloRequest typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg typeOfHandshake CertRequest{} = HandshakeType_CertRequest typeOfHandshake CertVerify{} = HandshakeType_CertVerify typeOfHandshake Finished{} = HandshakeType_Finished numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) numericalVer SSL3 = (3, 0) numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3) numericalVer TLS13 = (3, 4) verOfNum :: (Word8, Word8) -> Maybe Version verOfNum (2, 0) = Just SSL2 verOfNum (3, 0) = Just SSL3 verOfNum (3, 1) = Just TLS10 verOfNum (3, 2) = Just TLS11 verOfNum (3, 3) = Just TLS12 verOfNum (3, 4) = Just TLS13 verOfNum _ = Nothing class TypeValuable a where valOfType :: a -> Word8 valToType :: Word8 -> Maybe a -- a better name for TypeValuable class EnumSafe8 a where fromEnumSafe8 :: a -> Word8 toEnumSafe8 :: Word8 -> Maybe a class EnumSafe16 a where fromEnumSafe16 :: a -> Word16 toEnumSafe16 :: Word16 -> Maybe a instance TypeValuable ConnectionEnd where valOfType ConnectionServer = 0 valOfType ConnectionClient = 1 valToType 0 = Just ConnectionServer valToType 1 = Just ConnectionClient valToType _ = Nothing instance TypeValuable CipherType where valOfType CipherStream = 0 valOfType CipherBlock = 1 valOfType CipherAEAD = 2 valToType 0 = Just CipherStream valToType 1 = Just CipherBlock valToType 2 = Just CipherAEAD valToType _ = Nothing instance TypeValuable ProtocolType where valOfType ProtocolType_ChangeCipherSpec = 20 valOfType ProtocolType_Alert = 21 valOfType ProtocolType_Handshake = 22 valOfType ProtocolType_AppData = 23 valOfType ProtocolType_DeprecatedHandshake = 128 -- unused valToType 20 = Just ProtocolType_ChangeCipherSpec valToType 21 = Just ProtocolType_Alert valToType 22 = Just ProtocolType_Handshake valToType 23 = Just ProtocolType_AppData valToType _ = Nothing instance TypeValuable HandshakeType where valOfType HandshakeType_HelloRequest = 0 valOfType HandshakeType_ClientHello = 1 valOfType HandshakeType_ServerHello = 2 valOfType HandshakeType_Certificate = 11 valOfType HandshakeType_ServerKeyXchg = 12 valOfType HandshakeType_CertRequest = 13 valOfType HandshakeType_ServerHelloDone = 14 valOfType HandshakeType_CertVerify = 15 valOfType HandshakeType_ClientKeyXchg = 16 valOfType HandshakeType_Finished = 20 valToType 0 = Just HandshakeType_HelloRequest valToType 1 = Just HandshakeType_ClientHello valToType 2 = Just HandshakeType_ServerHello valToType 11 = Just HandshakeType_Certificate valToType 12 = Just HandshakeType_ServerKeyXchg valToType 13 = Just HandshakeType_CertRequest valToType 14 = Just HandshakeType_ServerHelloDone valToType 15 = Just HandshakeType_CertVerify valToType 16 = Just HandshakeType_ClientKeyXchg valToType 20 = Just HandshakeType_Finished valToType _ = Nothing instance TypeValuable AlertLevel where valOfType AlertLevel_Warning = 1 valOfType AlertLevel_Fatal = 2 valToType 1 = Just AlertLevel_Warning valToType 2 = Just AlertLevel_Fatal valToType _ = Nothing instance TypeValuable AlertDescription where valOfType CloseNotify = 0 valOfType UnexpectedMessage = 10 valOfType BadRecordMac = 20 valOfType DecryptionFailed = 21 valOfType RecordOverflow = 22 valOfType DecompressionFailure = 30 valOfType HandshakeFailure = 40 valOfType BadCertificate = 42 valOfType UnsupportedCertificate = 43 valOfType CertificateRevoked = 44 valOfType CertificateExpired = 45 valOfType CertificateUnknown = 46 valOfType IllegalParameter = 47 valOfType UnknownCa = 48 valOfType AccessDenied = 49 valOfType DecodeError = 50 valOfType DecryptError = 51 valOfType ExportRestriction = 60 valOfType ProtocolVersion = 70 valOfType InsufficientSecurity = 71 valOfType InternalError = 80 valOfType InappropriateFallback = 86 valOfType UserCanceled = 90 valOfType NoRenegotiation = 100 valOfType MissingExtension = 109 valOfType UnsupportedExtension = 110 valOfType CertificateUnobtainable = 111 valOfType UnrecognizedName = 112 valOfType BadCertificateStatusResponse = 113 valOfType BadCertificateHashValue = 114 valOfType UnknownPskIdentity = 115 valOfType CertificateRequired = 116 valOfType NoApplicationProtocol = 120 valToType 0 = Just CloseNotify valToType 10 = Just UnexpectedMessage valToType 20 = Just BadRecordMac valToType 21 = Just DecryptionFailed valToType 22 = Just RecordOverflow valToType 30 = Just DecompressionFailure valToType 40 = Just HandshakeFailure valToType 42 = Just BadCertificate valToType 43 = Just UnsupportedCertificate valToType 44 = Just CertificateRevoked valToType 45 = Just CertificateExpired valToType 46 = Just CertificateUnknown valToType 47 = Just IllegalParameter valToType 48 = Just UnknownCa valToType 49 = Just AccessDenied valToType 50 = Just DecodeError valToType 51 = Just DecryptError valToType 60 = Just ExportRestriction valToType 70 = Just ProtocolVersion valToType 71 = Just InsufficientSecurity valToType 80 = Just InternalError valToType 86 = Just InappropriateFallback valToType 90 = Just UserCanceled valToType 100 = Just NoRenegotiation valToType 109 = Just MissingExtension valToType 110 = Just UnsupportedExtension valToType 111 = Just CertificateUnobtainable valToType 112 = Just UnrecognizedName valToType 113 = Just BadCertificateStatusResponse valToType 114 = Just BadCertificateHashValue valToType 115 = Just UnknownPskIdentity valToType 116 = Just CertificateRequired valToType 120 = Just NoApplicationProtocol valToType _ = Nothing instance TypeValuable CertificateType where valOfType CertificateType_RSA_Sign = 1 valOfType CertificateType_ECDSA_Sign = 64 valOfType CertificateType_DSS_Sign = 2 valOfType CertificateType_RSA_Fixed_DH = 3 valOfType CertificateType_DSS_Fixed_DH = 4 valOfType CertificateType_RSA_Ephemeral_DH = 5 valOfType CertificateType_DSS_Ephemeral_DH = 6 valOfType CertificateType_fortezza_dms = 20 valOfType CertificateType_RSA_Fixed_ECDH = 65 valOfType CertificateType_ECDSA_Fixed_ECDH = 66 valOfType (CertificateType_Unknown i) = i -- | There are no code points that map to the below synthetic types, these -- are inferred indirectly from the @signature_algorithms@ extension of the -- TLS 1.3 @CertificateRequest@ message. the value assignments are there -- only to avoid partial function warnings. valOfType CertificateType_Ed25519_Sign = 0 valOfType CertificateType_Ed448_Sign = 0 valToType 1 = Just CertificateType_RSA_Sign valToType 2 = Just CertificateType_DSS_Sign valToType 3 = Just CertificateType_RSA_Fixed_DH valToType 4 = Just CertificateType_DSS_Fixed_DH valToType 5 = Just CertificateType_RSA_Ephemeral_DH valToType 6 = Just CertificateType_DSS_Ephemeral_DH valToType 20 = Just CertificateType_fortezza_dms valToType 64 = Just CertificateType_ECDSA_Sign valToType 65 = Just CertificateType_RSA_Fixed_ECDH valToType 66 = Just CertificateType_ECDSA_Fixed_ECDH valToType i = Just (CertificateType_Unknown i) -- | There are no code points that map to the below synthetic types, these -- are inferred indirectly from the @signature_algorithms@ extension of the -- TLS 1.3 @CertificateRequest@ message. -- @ -- CertificateType_Ed25519_Sign -- CertificateType_Ed448_Sign -- @ instance TypeValuable HashAlgorithm where valOfType HashNone = 0 valOfType HashMD5 = 1 valOfType HashSHA1 = 2 valOfType HashSHA224 = 3 valOfType HashSHA256 = 4 valOfType HashSHA384 = 5 valOfType HashSHA512 = 6 valOfType HashIntrinsic = 8 valOfType (HashOther i) = i valToType 0 = Just HashNone valToType 1 = Just HashMD5 valToType 2 = Just HashSHA1 valToType 3 = Just HashSHA224 valToType 4 = Just HashSHA256 valToType 5 = Just HashSHA384 valToType 6 = Just HashSHA512 valToType 8 = Just HashIntrinsic valToType i = Just (HashOther i) instance TypeValuable SignatureAlgorithm where valOfType SignatureAnonymous = 0 valOfType SignatureRSA = 1 valOfType SignatureDSS = 2 valOfType SignatureECDSA = 3 valOfType SignatureRSApssRSAeSHA256 = 4 valOfType SignatureRSApssRSAeSHA384 = 5 valOfType SignatureRSApssRSAeSHA512 = 6 valOfType SignatureEd25519 = 7 valOfType SignatureEd448 = 8 valOfType SignatureRSApsspssSHA256 = 9 valOfType SignatureRSApsspssSHA384 = 10 valOfType SignatureRSApsspssSHA512 = 11 valOfType (SignatureOther i) = i valToType 0 = Just SignatureAnonymous valToType 1 = Just SignatureRSA valToType 2 = Just SignatureDSS valToType 3 = Just SignatureECDSA valToType 4 = Just SignatureRSApssRSAeSHA256 valToType 5 = Just SignatureRSApssRSAeSHA384 valToType 6 = Just SignatureRSApssRSAeSHA512 valToType 7 = Just SignatureEd25519 valToType 8 = Just SignatureEd448 valToType 9 = Just SignatureRSApsspssSHA256 valToType 10 = Just SignatureRSApsspssSHA384 valToType 11 = Just SignatureRSApsspssSHA512 valToType i = Just (SignatureOther i) instance EnumSafe16 Group where fromEnumSafe16 P256 = 23 fromEnumSafe16 P384 = 24 fromEnumSafe16 P521 = 25 fromEnumSafe16 X25519 = 29 fromEnumSafe16 X448 = 30 fromEnumSafe16 FFDHE2048 = 256 fromEnumSafe16 FFDHE3072 = 257 fromEnumSafe16 FFDHE4096 = 258 fromEnumSafe16 FFDHE6144 = 259 fromEnumSafe16 FFDHE8192 = 260 toEnumSafe16 23 = Just P256 toEnumSafe16 24 = Just P384 toEnumSafe16 25 = Just P521 toEnumSafe16 29 = Just X25519 toEnumSafe16 30 = Just X448 toEnumSafe16 256 = Just FFDHE2048 toEnumSafe16 257 = Just FFDHE3072 toEnumSafe16 258 = Just FFDHE4096 toEnumSafe16 259 = Just FFDHE6144 toEnumSafe16 260 = Just FFDHE8192 toEnumSafe16 _ = Nothing tls-1.5.4/Network/TLS/Sending.hs0000644000000000000000000001041013623162342014525 0ustar0000000000000000-- | -- Module : Network.TLS.Sending -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Sending module contains calls related to marshalling packets according -- to the TLS state -- module Network.TLS.Sending ( encodePacket , encodeRecordM , updateHandshake ) where import Network.TLS.Cap import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.Record import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types (Role(..)) import Network.TLS.Util import Control.Concurrent.MVar import Control.Monad.State.Strict import qualified Data.ByteString as B import Data.IORef -- | encodePacket transform a packet into marshalled data related to current state -- and updating state on the go encodePacket :: Context -> Packet -> IO (Either TLSError ByteString) encodePacket ctx pkt = do (ver, _) <- decideRecordVersion ctx let pt = packetType pkt mkRecord bs = Record pt ver (fragmentPlaintext bs) records <- map mkRecord <$> packetToFragments ctx 16384 pkt bs <- fmap B.concat <$> forEitherM records (encodeRecord 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. packetToFragments :: Context -> Int -> Packet -> IO [ByteString] packetToFragments ctx len (Handshake hss) = getChunks len . B.concat <$> mapM (updateHandshake ctx ClientRole) hss packetToFragments _ _ (Alert a) = return [encodeAlerts a] packetToFragments _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments _ _ (AppData x) = return [x] -- before TLS 1.1, the block cipher IV is made of the residual of the previous block, -- so we use cstIV as is, however in other case we generate an explicit IV prepareRecord :: Context -> RecordM a -> IO (Either TLSError a) prepareRecord ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) txState <- readMVar $ ctxTxState ctx let sz = case stCipher txState of Nothing -> 0 Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher then bulkIVSize $ cipherBulk cipher else 0 -- to not generate IV if hasExplicitBlockIV ver && sz > 0 then do newIV <- getStateRNG ctx sz runTxState ctx (modify (setRecordIV newIV) >> f) else runTxState ctx f encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString) encodeRecord ctx = prepareRecord ctx . encodeRecordM encodeRecordM :: Record Plaintext -> RecordM ByteString encodeRecordM record = do erecord <- engageRecord record let (hdr, content) = recordToRaw erecord return $ B.concat [ encodeHeader hdr, content ] switchTxEncryption :: Context -> IO () switchTxEncryption ctx = do tx <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState) (ver, cc) <- usingState_ ctx $ do v <- getVersion c <- isClientContext return (v, c) liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx) -- set empty packet counter measure if condition are met when (ver <= TLS10 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) updateHandshake :: Context -> Role -> Handshake -> IO ByteString updateHandshake ctx role hs = do case hs of Finished fdata -> usingState_ ctx $ updateVerifiedData role fdata _ -> return () usingHState ctx $ do when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded return encoded where encoded = encodeHandshake hs tls-1.5.4/Network/TLS/X509.hs0000644000000000000000000000433113623162342013610 0ustar0000000000000000-- | -- Module : Network.TLS.X509 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- X509 helpers -- module Network.TLS.X509 ( CertificateChain(..) , Certificate(..) , SignedCertificate , getCertificate , isNullCertificateChain , getCertificateChainLeaf , CertificateRejectReason(..) , CertificateUsage(..) , CertificateStore , ValidationCache , exceptionValidationCache , validateDefault , FailedReason , ServiceID , wrapCertificateChecks , pubkeyType ) where import Data.X509 import Data.X509.Validation import Data.X509.CertificateStore 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 = CertificateUsageAccept -- ^ usage of certificate accepted | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected 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 tls-1.5.4/Network/TLS/Credentials.hs0000644000000000000000000001730213623162342015402 0ustar0000000000000000-- | -- Module : Network.TLS.Credentials -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE CPP #-} module Network.TLS.Credentials ( Credential , Credentials(..) , credentialLoadX509 , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory , credentialsFindForSigning , credentialsFindForDecrypting , credentialsListSigningAlgorithms , credentialPublicPrivateKeys , credentialMatchesHashSignatures ) where import Network.TLS.Crypto import Network.TLS.X509 import Network.TLS.Imports import Data.X509.File import Data.X509.Memory import Data.X509 import qualified Data.X509 as X509 import qualified Network.TLS.Struct as TLS type Credential = (CertificateChain, PrivKey) newtype Credentials = Credentials [Credential] #if MIN_VERSION_base(4,9,0) instance Semigroup Credentials where Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2) #endif 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 = do 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.SignatureDSS 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-1.5.4/Network/TLS/KeySchedule.hs0000644000000000000000000000433313623162342015352 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.KeySchedule -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- 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.Wire import Network.TLS.Imports ---------------------------------------------------------------- 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 ---------------------------------------------------------------- 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-1.5.4/Network/TLS/Struct13.hs0000644000000000000000000000756113623162342014603 0ustar0000000000000000-- | -- Module : Network.TLS.Struct13 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Struct13 ( Packet13(..) , Handshake13(..) , HandshakeType13(..) , typeOfHandshake13 , contentType , KeyUpdate(..) ) where import Data.X509 (CertificateChain) import Network.TLS.Struct import Network.TLS.Types import Network.TLS.Imports 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 = ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw] | ServerHello13 !ServerRandom !Session !CipherID [ExtensionRaw] | NewSessionTicket13 Second Word32 TicketNonce SessionID [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw] | CertRequest13 CertReqContext [ExtensionRaw] | Certificate13 CertReqContext CertificateChain [[ExtensionRaw]] | CertVerify13 HashAndSignatureAlgorithm Signature | Finished13 FinishedData | KeyUpdate13 KeyUpdate deriving (Show,Eq) data HandshakeType13 = HandshakeType_ClientHello13 | HandshakeType_ServerHello13 | HandshakeType_EndOfEarlyData13 | HandshakeType_NewSessionTicket13 | HandshakeType_EncryptedExtensions13 | HandshakeType_CertRequest13 | HandshakeType_Certificate13 | HandshakeType_CertVerify13 | HandshakeType_Finished13 | HandshakeType_KeyUpdate13 deriving (Show,Eq) typeOfHandshake13 :: Handshake13 -> HandshakeType13 typeOfHandshake13 ClientHello13{} = HandshakeType_ClientHello13 typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello13 typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData13 typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket13 typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions13 typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest13 typeOfHandshake13 Certificate13{} = HandshakeType_Certificate13 typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify13 typeOfHandshake13 Finished13{} = HandshakeType_Finished13 typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate13 instance TypeValuable HandshakeType13 where valOfType HandshakeType_ClientHello13 = 1 valOfType HandshakeType_ServerHello13 = 2 valOfType HandshakeType_NewSessionTicket13 = 4 valOfType HandshakeType_EndOfEarlyData13 = 5 valOfType HandshakeType_EncryptedExtensions13 = 8 valOfType HandshakeType_CertRequest13 = 13 valOfType HandshakeType_Certificate13 = 11 valOfType HandshakeType_CertVerify13 = 15 valOfType HandshakeType_Finished13 = 20 valOfType HandshakeType_KeyUpdate13 = 24 valToType 1 = Just HandshakeType_ClientHello13 valToType 2 = Just HandshakeType_ServerHello13 valToType 4 = Just HandshakeType_NewSessionTicket13 valToType 5 = Just HandshakeType_EndOfEarlyData13 valToType 8 = Just HandshakeType_EncryptedExtensions13 valToType 13 = Just HandshakeType_CertRequest13 valToType 11 = Just HandshakeType_Certificate13 valToType 15 = Just HandshakeType_CertVerify13 valToType 20 = Just HandshakeType_Finished13 valToType 24 = Just HandshakeType_KeyUpdate13 valToType _ = Nothing contentType :: Packet13 -> ProtocolType contentType ChangeCipherSpec13 = ProtocolType_ChangeCipherSpec contentType (Handshake13 _) = ProtocolType_Handshake contentType (Alert13 _) = ProtocolType_Alert contentType (AppData13 _) = ProtocolType_AppData tls-1.5.4/Network/TLS/Backend.hs0000644000000000000000000000701613623162342014475 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Backend -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- A Backend represents a unified way to do IO on different -- 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 Network.TLS.Imports import qualified Data.ByteString as B import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) #ifdef INCLUDE_NETWORK import qualified Network.Socket as Network (Socket, close) import qualified Network.Socket.ByteString as Network #endif #ifdef INCLUDE_HANS import qualified Data.ByteString.Lazy as L import qualified Hans.NetworkStack as Hans #endif -- | 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 #if defined(__GLASGOW_HASKELL__) && WINDOWS -- Socket recv and accept calls on Windows platform cannot be interrupted when compiled with -threaded. -- See https://ghc.haskell.org/trac/ghc/ticket/5797 for details. -- The following enables simple workaround #define SOCKET_ACCEPT_RECV_WORKAROUND #endif safeRecv :: Network.Socket -> Int -> IO ByteString #ifndef SOCKET_ACCEPT_RECV_WORKAROUND safeRecv = Network.recv #else safeRecv s buf = do var <- newEmptyMVar forkIO $ Network.recv s buf `E.catch` (\(_::IOException) -> return S8.empty) >>= putMVar var takeMVar var #endif #ifdef INCLUDE_NETWORK instance HasBackend Network.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll where recvAll n = B.concat <$> loop n where loop 0 = return [] loop left = do r <- safeRecv sock left if B.null r then return [] else (r:) <$> loop (left - B.length r) #endif #ifdef INCLUDE_HANS instance HasBackend Hans.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Hans.close sock) sendAll recvAll where sendAll x = do amt <- fromIntegral <$> Hans.sendBytes sock (L.fromStrict x) if (amt == 0) || (amt == B.length x) then return () else sendAll (B.drop amt x) recvAll n = loop (fromIntegral n) L.empty loop 0 acc = return (L.toStrict acc) loop left acc = do r <- Hans.recvBytes sock left if L.null r then loop 0 acc else loop (left - L.length r) (acc `L.append` r) #endif instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering getBackend handle = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle) tls-1.5.4/Network/TLS/Hooks.hs0000644000000000000000000000344213623162342014230 0ustar0000000000000000-- | -- Module : Network.TLS.Context -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Hooks ( Logging(..) , Hooks(..) , defaultHooks ) where import qualified Data.ByteString as B import Network.TLS.Struct (Header, Handshake) import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain) import Data.Default.Class -- | 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 { -- | called at each handshake message received hookRecvHandshake :: Handshake -> IO Handshake -- | called at each handshake message received for TLS 1.3 , hookRecvHandshake13 :: Handshake13 -> IO Handshake13 -- | called at each certificate chain message received , hookRecvCertificates :: CertificateChain -> IO () -- | hooks on IO and packets, receiving and sending. , hookLogging :: Logging } defaultHooks :: Hooks defaultHooks = Hooks { hookRecvHandshake = return , hookRecvHandshake13 = return , hookRecvCertificates = return . const () , hookLogging = def } instance Default Hooks where def = defaultHooks tls-1.5.4/Network/TLS/Internal.hs0000644000000000000000000000136013623162342014716 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Network.TLS.Internal -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Internal ( module Network.TLS.Struct , module Network.TLS.Struct13 , module Network.TLS.Packet , module Network.TLS.Packet13 , module Network.TLS.Receiving , module Network.TLS.Sending , module Network.TLS.Wire , sendPacket , recvPacket ) where import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Receiving import Network.TLS.Sending import Network.TLS.Wire import Network.TLS.Core (sendPacket, recvPacket) tls-1.5.4/Network/TLS/Sending13.hs0000644000000000000000000000436613623162342014706 0ustar0000000000000000-- | -- Module : Network.TLS.Sending13 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Sending module contains calls related to marshalling packets according -- to the TLS state -- module Network.TLS.Sending13 ( encodePacket13 , updateHandshake13 ) where import Network.TLS.Context.Internal import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Record import Network.TLS.Sending import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Util import qualified Data.ByteString as B encodePacket13 :: Context -> Packet13 -> IO (Either TLSError ByteString) encodePacket13 ctx pkt = do let pt = contentType pkt mkRecord bs = Record pt TLS12 (fragmentPlaintext bs) records <- map mkRecord <$> packetToFragments ctx 16384 pkt fmap B.concat <$> forEitherM records (encodeRecord ctx) prepareRecord :: Context -> RecordM a -> IO (Either TLSError a) prepareRecord = runTxState encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString) encodeRecord ctx = prepareRecord ctx . encodeRecordM packetToFragments :: Context -> Int -> Packet13 -> IO [ByteString] packetToFragments ctx len (Handshake13 hss) = getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss packetToFragments _ _ (Alert13 a) = return [encodeAlerts a] packetToFragments _ _ (AppData13 x) = return [x] packetToFragments _ _ 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-1.5.4/Network/TLS/Handshake.hs0000644000000000000000000000227513623162342015036 0ustar0000000000000000-- | -- Module : Network.TLS.Handshake -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake ( handshake , handshakeWith , handshakeClientWith , handshakeServerWith , handshakeClient , handshakeServer ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State.Strict -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegotiation handshake :: MonadIO m => Context -> m () handshake ctx = liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx) -- Handshake when requested by the remote end -- This is called automatically by 'recvData', in a context where the read lock -- is already taken. So contrary to 'handshake' above, here we only need to -- call withWriteLock. handshakeWith :: MonadIO m => Context -> Handshake -> m () handshakeWith ctx hs = liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoHandshakeWith ctx ctx hs tls-1.5.4/Network/TLS/Extra.hs0000644000000000000000000000060013623162342014221 0ustar0000000000000000-- | -- Module : Network.TLS.Extra -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- default values and ciphers module Network.TLS.Extra ( module Network.TLS.Extra.Cipher , module Network.TLS.Extra.FFDHE ) where import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE tls-1.5.4/Network/TLS/Imports.hs0000644000000000000000000000306613623162342014604 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-dodgy-exports #-} -- Char8 -- | -- Module : Network.TLS.Imports -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Imports ( -- generic exports ByteString , module Data.ByteString.Char8 -- instance , module Control.Applicative , module Control.Monad #if !MIN_VERSION_base(4,13,0) , MonadFail #endif , module Data.Bits , module Data.List , module Data.Maybe #if MIN_VERSION_base(4,9,0) , module Data.Semigroup #else , module Data.Monoid #endif , module Data.Ord , module Data.Word #if !MIN_VERSION_base(4,8,0) , sortOn #endif -- project definition , showBytesHex ) where import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Control.Applicative import Control.Monad #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif import Data.Bits import Data.List import Data.Maybe hiding (fromJust) #if MIN_VERSION_base(4,9,0) import Data.Semigroup #else import Data.Monoid #endif import Data.Ord import Data.Word import Data.ByteArray.Encoding as B import qualified Prelude as P #if !MIN_VERSION_base(4,8,0) import Prelude ((.)) sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f = map P.snd . sortBy (comparing P.fst) . map (\x -> let y = f x in y `P.seq` (y, x)) #endif showBytesHex :: ByteString -> P.String showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString) tls-1.5.4/Network/TLS/Types.hs0000644000000000000000000000615313623162342014253 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Types ( Version(..) , SessionID , SessionData(..) , SessionFlag(..) , CertReqContext , TLS13TicketInfo(..) , CipherID , CompressionID , Role(..) , invertRole , Direction(..) , HostName , Second , Millisecond , EarlySecret , HandshakeSecret , ApplicationSecret , ResumptionSecret , BaseSecret(..) , ClientTrafficSecret(..) , ServerTrafficSecret(..) , SecretTriple(..) , SecretPair(..) , MasterSecret(..) ) where import Network.TLS.Imports import Network.TLS.Crypto.Types (Group) type HostName = String type Second = Word32 type Millisecond = Word64 -- | Versions known to TLS -- -- SSL2 is just defined, but this version is and will not be supported. data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 | TLS13 deriving (Show, Eq, Ord, Bounded) -- | A session ID type SessionID = ByteString -- | Session data to resume data SessionData = SessionData { sessionVersion :: Version , sessionCipher :: CipherID , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName , sessionSecret :: ByteString , sessionGroup :: Maybe Group , sessionTicketInfo :: Maybe TLS13TicketInfo , sessionALPN :: Maybe ByteString , sessionMaxEarlyDataSize :: Int , sessionFlags :: [SessionFlag] } deriving (Show,Eq) -- | Some session flags data SessionFlag = SessionEMS -- ^ Session created with Extended Master Secret deriving (Show,Eq,Enum) -- | Certificate request context for TLS 1.3. type CertReqContext = ByteString data TLS13TicketInfo = TLS13TicketInfo { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds , ageAdd :: Second -- NewSessionTicket.ticket_age_add , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime , estimatedRTT :: Maybe Millisecond } deriving (Show, Eq) -- | Cipher identification type CipherID = Word16 -- | Compression identification type CompressionID = Word8 -- | Role data Role = ClientRole | ServerRole deriving (Show,Eq) -- | Direction data Direction = Tx | Rx deriving (Show,Eq) invertRole :: Role -> Role invertRole ClientRole = ServerRole invertRole ServerRole = ClientRole data EarlySecret data HandshakeSecret data ApplicationSecret data ResumptionSecret newtype BaseSecret a = BaseSecret ByteString deriving Show newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving Show newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving Show data SecretTriple a = SecretTriple { triBase :: BaseSecret a , triClient :: ClientTrafficSecret a , triServer :: ServerTrafficSecret a } data SecretPair a = SecretPair { pairBase :: BaseSecret a , pairClient :: ClientTrafficSecret a } -- Master secret for TLS 1.2 or earlier. newtype MasterSecret = MasterSecret ByteString deriving Show tls-1.5.4/Network/TLS/Packet13.hs0000644000000000000000000001570213623162342014522 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Network.TLS.Packet13 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Packet13 ( encodeHandshake13 , getHandshakeType13 , decodeHandshakeRecord13 , decodeHandshake13 , decodeHandshakes13 ) where import qualified Data.ByteString as B import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Packet import Network.TLS.Wire import Network.TLS.Imports import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) import Network.TLS.ErrT encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt where !tp = typeOfHandshake13 hdsk !content = encodeHandshake13' hdsk !len = B.length content !header = encodeHandshakeHeader13 tp len !pkt = B.concat [header, content] -- TLS 1.3 does not use "select (extensions_present)". putExtensions :: [ExtensionRaw] -> Put putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString encodeHandshake13' (ClientHello13 version random session cipherIDs exts) = runPut $ do putBinaryVersion version putClientRandom32 random putSession session putWords16 cipherIDs putWords8 [0] putExtensions exts encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do putBinaryVersion TLS12 putServerRandom32 random putSession session putWord16 cipherId putWord8 0 -- compressionID nullCompression putExtensions exts encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts encodeHandshake13' (Certificate13 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 encodeHandshake13' (CertVerify13 hs signature) = runPut $ do putSignatureHashAlgorithm hs putOpaque16 signature encodeHandshake13' (Finished13 dat) = runPut $ putBytes dat encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do putWord32 life putWord32 ageadd putOpaque8 nonce putOpaque16 label putExtensions exts encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1 encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do putWord8 (valOfType ty) putWord24 len decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of GotError err -> throwError err GotPartial _cont -> error "decodeHandshakes13" GotSuccess (ty,content) -> case decodeHandshake13 ty content of Left e -> throwError e Right h -> return [h] GotSuccessRemaining (ty,content) left -> case decodeHandshake13 ty content of Left e -> throwError e Right h -> (h:) <$> decodeHandshakes13 left {- decode and encode HANDSHAKE -} getHandshakeType13 :: Get HandshakeType13 getHandshakeType13 = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid handshake type: " ++ show ty) Just t -> return t decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType13, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do ty <- getHandshakeType13 content <- getOpaque24 return (ty, content) decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_ClientHello13 -> decodeClientHello13 HandshakeType_ServerHello13 -> decodeServerHello13 HandshakeType_Finished13 -> decodeFinished13 HandshakeType_EncryptedExtensions13 -> decodeEncryptedExtensions13 HandshakeType_CertRequest13 -> decodeCertRequest13 HandshakeType_Certificate13 -> decodeCertificate13 HandshakeType_CertVerify13 -> decodeCertVerify13 HandshakeType_NewSessionTicket13 -> decodeNewSessionTicket13 HandshakeType_EndOfEarlyData13 -> return EndOfEarlyData13 HandshakeType_KeyUpdate13 -> decodeKeyUpdate13 decodeClientHello13 :: Get Handshake13 decodeClientHello13 = do Just ver <- getBinaryVersion random <- getClientRandom32 session <- getSession ciphers <- getWords16 _comp <- getWords8 exts <- fromIntegral <$> getWord16 >>= getExtensions return $ ClientHello13 ver random session ciphers exts decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do Just _ver <- getBinaryVersion random <- getServerRandom32 session <- getSession cipherid <- getWord16 _comp <- getWord8 exts <- fromIntegral <$> getWord16 >>= getExtensions return $ ServerHello13 random session cipherid exts decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 <$> (remaining >>= getBytes) decodeEncryptedExtensions13 :: Get Handshake13 decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do len <- fromIntegral <$> getWord16 getExtensions len decodeCertRequest13 :: Get Handshake13 decodeCertRequest13 = do reqctx <- getOpaque8 len <- fromIntegral <$> getWord16 exts <- getExtensions len return $ CertRequest13 reqctx exts 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 cc ess where getCert = do l <- fromIntegral <$> getWord24 cert <- getBytes l len <- fromIntegral <$> getWord16 exts <- getExtensions len return (3 + l + 2 + len, (cert, exts)) decodeCertVerify13 :: Get Handshake13 decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16 decodeNewSessionTicket13 :: Get Handshake13 decodeNewSessionTicket13 = do life <- getWord32 ageadd <- getWord32 nonce <- getOpaque8 label <- getOpaque16 len <- fromIntegral <$> getWord16 exts <- getExtensions len return $ NewSessionTicket13 life ageadd nonce label exts 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 tls-1.5.4/Network/TLS/Receiving13.hs0000644000000000000000000000422113623162342015220 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Network.TLS.Receiving13 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state -- module Network.TLS.Receiving13 ( processPacket13 ) where import Network.TLS.Context.Internal import Network.TLS.ErrT import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Record.Types import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Util import Network.TLS.Wire import Control.Monad.State processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13) processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13 processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment processPacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment)) processPacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do mCont <- gets stHandshakeRecordCont13 modify (\st -> st { stHandshakeRecordCont13 = Nothing }) hss <- parseMany mCont (fragmentGetBytes fragment) return $ Handshake13 hss where parseMany mCont bs = case fromMaybe decodeHandshakeRecord13 mCont bs of GotError err -> throwError err GotPartial cont -> modify (\st -> st { stHandshakeRecordCont13 = Just cont }) >> return [] GotSuccess (ty,content) -> either throwError (return . (:[])) $ decodeHandshake13 ty content GotSuccessRemaining (ty,content) left -> case decodeHandshake13 ty content of Left err -> throwError err Right hh -> (hh:) <$> parseMany Nothing left processPacket13 _ (Record ProtocolType_DeprecatedHandshake _ _) = return (Left $ Error_Packet "deprecated handshake packet 1.3") tls-1.5.4/Network/TLS/Core.hs0000644000000000000000000003527113623162342014042 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-} -- | -- Module : Network.TLS.Core -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Core ( -- * Internal packet sending and receiving sendPacket , recvPacket -- * 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 Network.TLS.Cipher import Network.TLS.Context import Network.TLS.Crypto import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.State (getSession) import Network.TLS.Parameters import Network.TLS.IO import Network.TLS.Session import Network.TLS.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.PostHandshake import Network.TLS.KeySchedule import Network.TLS.Types (Role(..), HostName) import Network.TLS.Util (catchException, mapChunks_) import Network.TLS.Extension import qualified Network.TLS.State as S import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E import Control.Monad.State.Strict -- | 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 bye :: MonadIO m => Context -> m () bye ctx = liftIO $ do -- Although setEOF is always protected by the read lock, here we don't try -- to wrap ctxEOF with it, so that function bye can still be called -- concurrently to a blocked recvData. eof <- ctxEOF ctx tls13 <- tls13orLater ctx unless eof $ withWriteLock ctx $ if tls13 then sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)] else sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | 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 -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => Context -> L.ByteString -> m () sendData ctx dataToSend = liftIO $ do tls13 <- tls13orLater ctx let sendP | tls13 = sendPacket13 ctx . AppData13 | otherwise = sendPacket ctx . AppData 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. mapM_ (mapChunks_ 16384 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 recvData1/recvData13 loops, we only need to call function -- checkValid once. Since we hold the read lock, no concurrent call -- will impact the validity of the context. if tls13 then recvData13 ctx else recvData1 ctx recvData1 :: Context -> IO B.ByteString recvData1 ctx = do pkt <- recvPacket ctx either (onError terminate) process pkt where process (Handshake [ch@ClientHello{}]) = handshakeWith ctx ch >> recvData1 ctx process (Handshake [hr@HelloRequest]) = handshakeWith ctx hr >> recvData1 ctx process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) -- when receiving empty appdata, we just retry to get some data. process (AppData "") = recvData1 ctx process (AppData x) = return x process p = let reason = "unexpected message " ++ show p in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason terminate = terminateWithWriteLock ctx (sendPacket ctx . Alert) recvData13 :: Context -> IO B.ByteString recvData13 ctx = do pkt <- recvPacket13 ctx either (onError terminate) process pkt where process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty process (Alert13 [(AlertLevel_Fatal, desc)]) = do setEOF ctx E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) process (Handshake13 hs) = do loopHandshake13 hs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. process (AppData13 "") = recvData13 ctx process (AppData13 x) = do let chunkLen = C8.length x established <- ctxEstablished ctx case established of EarlyDataAllowed maxSize | chunkLen <= maxSize -> do setEstablished ctx $ EarlyDataAllowed (maxSize - chunkLen) return x | otherwise -> let reason = "early data overflow" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x" | otherwise -> let reason = "early data deprotect overflow" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> return x NotEstablished -> throwCore $ Error_Protocol ("data at not-established", True, UnexpectedMessage) process ChangeCipherSpec13 = recvData13 ctx process p = let reason = "unexpected message " ++ show p in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 [] = return () loopHandshake13 (ClientHello13{}:_) = do let reason = "Client hello is not allowed" terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. loopHandshake13 (NewSessionTicket13 life add nonce label exts:hs) = do role <- usingState_ ctx S.isClientContext unless (role == ClientRole) $ let reason = "Session ticket is allowed for client only" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager). withWriteLock ctx $ do Just resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret (_, usedCipher, _) <- getTxState ctx let choice = makeCipherChoice TLS13 usedCipher psk = derivePSK choice resumptionMasterSecret nonce maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms _ -> 0 life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk let !label' = B.copy label sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec" loopHandshake13 hs loopHandshake13 (KeyUpdate13 mode:hs) = do checkAlignment hs established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal. -- So, we don't have to check if this key update is corresponding -- to key update (update_requested) which we sent. if established == Established then do keyUpdate ctx getRxState setRxState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] keyUpdate ctx getTxState setTxState loopHandshake13 hs else do let reason = "received key update before established" terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 (h@CertRequest13{}:hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h@Certificate13{}:hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h:hs) = do mPendingAction <- popPendingAction ctx case mPendingAction of Nothing -> let reason = "unexpected handshake message " ++ show h in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Just action -> do -- Pending actions are executed with read+write locks, just -- like regular handshake code. withWriteLock ctx $ handleException ctx $ case action of PendingAction needAligned pa -> do when needAligned $ checkAlignment hs processHandshake13 ctx h >> pa h PendingActionHash needAligned pa -> do when needAligned $ checkAlignment hs d <- transcriptHash ctx processHandshake13 ctx h pa d h loopHandshake13 hs terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) checkAlignment hs = do complete <- isRecvComplete ctx unless (complete && null hs) $ let reason = "received message not aligned with record boundary" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- 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@(Error_Protocol (reason,fatal,desc)) = terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason onError terminate err = terminate err AlertLevel_Fatal InternalError (show err) terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ()) -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminateWithWriteLock ctx send err level desc reason = do session <- usingState_ ctx getSession -- Session manager is always invoked with read+write locks, so we merge this -- with the alert packet being emitted. withWriteLock ctx $ do case session of Session Nothing -> return () Session (Just sid) -> 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,C8.ByteString)) -> (Context -> Hash -> Cipher -> C8.ByteString -> IO ()) -> IO () keyUpdate ctx getState setState = do (usedHash, usedCipher, applicationSecretN) <- getState ctx let applicationSecretN1 = hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash setState ctx usedHash usedCipher applicationSecretN1 -- | How to update keys in TLS 1.3 data KeyUpdateRequest = OneWay -- ^ Unidirectional key update | TwoWay -- ^ Bidirectional key update (normal case) deriving (Eq, Show) -- | Updating appication traffic secrets for TLS 1.3. -- If this API is called for TLS 1.3, 'True' is returned. -- Otherwise, 'False' is returned. updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool updateKey ctx way = liftIO $ do tls13 <- tls13orLater ctx when tls13 $ do let req = case way of OneWay -> UpdateNotRequested TwoWay -> UpdateRequested -- Write lock wraps both actions because we don't want another packet to -- be sent by another thread before the Tx state is updated. withWriteLock ctx $ do sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] keyUpdate ctx getTxState setTxState return tls13 tls-1.5.4/Network/TLS/Session.hs0000644000000000000000000000246713623162342014576 0ustar0000000000000000-- | -- Module : Network.TLS.Session -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Session ( SessionManager(..) , noSessionManager ) where import Network.TLS.Types -- | A session manager data SessionManager = SessionManager { -- | used on server side to decide whether to resume a client session. sessionResume :: SessionID -> IO (Maybe SessionData) -- | used on server side to decide whether to resume a client session for TLS 1.3 0RTT. For a given 'SessionID', the implementation must return its 'SessionData' only once and must not return the same 'SessionData' after the call. , sessionResumeOnlyOnce :: SessionID -> IO (Maybe SessionData) -- | used when a session is established. , sessionEstablish :: SessionID -> SessionData -> IO () -- | used when a session is invalidated. , sessionInvalidate :: SessionID -> IO () } -- | The session manager to do nothing. noSessionManager :: SessionManager noSessionManager = SessionManager { sessionResume = \_ -> return Nothing , sessionResumeOnlyOnce = \_ -> return Nothing , sessionEstablish = \_ _ -> return () , sessionInvalidate = \_ -> return () } tls-1.5.4/Network/TLS/ErrT.hs0000644000000000000000000000121313623162342014013 0ustar0000000000000000-- | -- Module : Network.TLS.ErrT -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- a simple compat ErrorT and other error stuff {-# LANGUAGE CPP #-} module Network.TLS.ErrT ( runErrT , ErrT , Error(..) , MonadError(..) ) where #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except import Control.Monad.Error.Class (Error(..)) runErrT :: ExceptT e m a -> m (Either e a) runErrT = runExceptT type ErrT = ExceptT #else import Control.Monad.Error runErrT :: ErrorT e m a -> m (Either e a) runErrT = runErrorT type ErrT = ErrorT #endif tls-1.5.4/Network/TLS/Measurement.hs0000644000000000000000000000271113623162342015430 0ustar0000000000000000-- | -- Module : Network.TLS.Measurement -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Measurement ( Measurement(..) , newMeasurement , addBytesReceived , addBytesSent , resetBytesCounters , incrementNbHandshakes ) where 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-1.5.4/Network/TLS/PostHandshake.hs0000644000000000000000000000246613623162342015706 0ustar0000000000000000-- | -- Module : Network.TLS.PostHandshake -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module 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.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State.Strict -- | Post-handshake certificate request with TLS 1.3. Returns 'True' if the -- request was possible, i.e. if TLS 1.3 is used and the remote client supports -- post-handshake authentication. requestCertificate :: MonadIO m => Context -> m Bool requestCertificate ctx = liftIO $ withWriteLock ctx $ checkValid ctx >> ctxDoRequestCertificate ctx ctx -- Handle a post-handshake authentication flight with TLS 1.3. This is called -- automatically by 'recvData', in a context where the read lock is already -- taken. postHandshakeAuthWith :: MonadIO m => Context -> Handshake13 -> m () postHandshakeAuthWith ctx hs = liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoPostHandshakeAuthWith ctx ctx hs tls-1.5.4/Network/TLS/IO.hs0000644000000000000000000002760213623162342013460 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Network.TLS.IO -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.IO ( sendPacket , sendPacket13 , recvPacket , 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 System.IO.Error (mkIOError, eofErrorType) import Network.TLS.Context.Internal import Network.TLS.ErrT import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Receiving import Network.TLS.Receiving13 import Network.TLS.Record import Network.TLS.Sending import Network.TLS.Sending13 import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 ---------------------------------------------------------------- -- | Send one packet to the context sendPacket :: MonadIO m => Context -> Packet -> m () sendPacket ctx 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 <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $ writePacketBytes ctx (AppData B.empty) >>= sendBytes ctx writePacketBytes ctx pkt >>= sendBytes ctx where isNonNullAppData (AppData b) = not $ B.null b isNonNullAppData _ = False writePacketBytes :: MonadIO m => Context -> Packet -> m ByteString writePacketBytes ctx pkt = do edataToSend <- liftIO $ do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) encodePacket ctx pkt either throwCore return edataToSend ---------------------------------------------------------------- sendPacket13 :: MonadIO m => Context -> Packet13 -> m () sendPacket13 ctx pkt = writePacketBytes13 ctx pkt >>= sendBytes ctx writePacketBytes13 :: MonadIO m => Context -> Packet13 -> m ByteString writePacketBytes13 ctx pkt = do edataToSend <- liftIO $ do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) encodePacket13 ctx pkt either throwCore return edataToSend sendBytes :: MonadIO m => Context -> ByteString -> m () sendBytes ctx dataToSend = liftIO $ do withLog ctx $ \logging -> loggingIOSent logging dataToSend contextSend ctx dataToSend ---------------------------------------------------------------- getRecord :: Context -> Int -> Header -> ByteString -> IO (Either TLSError (Record Plaintext)) getRecord ctx appDataOverhead header@(Header pt _ _) content = do withLog ctx $ \logging -> loggingIORecv logging header content runRxState ctx $ do r <- decodeRecordM header content let Record _ _ fragment = r when (B.length (fragmentGetBytes fragment) > 16384 + overhead) $ throwError contentSizeExceeded return r where overhead = if pt == ProtocolType_AppData then appDataOverhead else 0 contentSizeExceeded :: TLSError contentSizeExceeded = Error_Protocol ("record content exceeding maximum size", True, RecordOverflow) ---------------------------------------------------------------- -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket :: MonadIO m => Context -> m (Either TLSError Packet) recvPacket ctx = liftIO $ do compatSSLv2 <- ctxHasSSLv2ClientHello ctx hrr <- usingState_ ctx getTLS13HRR -- When a client sends 0-RTT data to a server which rejects and sends a HRR, -- the server will not decrypt AppData segments. The server needs to accept -- AppData with maximum size 2^14 + 256. In all other scenarios and record -- types the maximum size is 2^14. let appDataOverhead = if hrr then 256 else 0 erecord <- recvRecord compatSSLv2 appDataOverhead ctx case erecord of Left err -> return $ Left err Right record -> if hrr && isCCS record then recvPacket ctx else do pktRecv <- processPacket ctx record if isEmptyHandshake pktRecv then -- When a handshake record is fragmented we continue -- receiving in order to feed stHandshakeRecordCont recvPacket ctx else do pkt <- case pktRecv of Right (Handshake hss) -> ctxWithHooks ctx $ \hooks -> Right . Handshake <$> mapM (hookRecvHandshake hooks) hss _ -> return pktRecv case pkt of Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p _ -> return () when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx return pkt -- | recvRecord receive a full TLS record (header + data), from the other side. -- -- The record is disengaged from the record layer recvRecord :: Bool -- ^ flag to enable SSLv2 compat ClientHello reception -> Int -- ^ number of AppData bytes to accept above normal maximum size -> Context -- ^ TLS context -> IO (Either TLSError (Record Plaintext)) recvRecord compatSSLv2 appDataOverhead ctx #ifdef SSLV2_COMPATIBLE | compatSSLv2 = readExactBytes ctx 2 >>= either (return . Left) sslv2Header #endif | otherwise = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) where recvLengthE = either (return . Left) recvLength recvLength header@(Header _ _ readlen) | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded | otherwise = readExactBytes ctx (fromIntegral readlen) >>= either (return . Left) (getRecord ctx appDataOverhead header) #ifdef SSLV2_COMPATIBLE sslv2Header header = if B.head header >= 0x80 then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header else readExactBytes ctx 3 >>= either (return . Left) (recvLengthE . decodeHeader . B.append header) recvDeprecatedLength readlen | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do res <- readExactBytes ctx (fromIntegral readlen) case res of Left e -> return $ Left e Right content -> let hdr = decodeDeprecatedHeader readlen (B.take 3 content) in either (return . Left) (\h -> getRecord ctx appDataOverhead h content) hdr #endif isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool isEmptyHandshake (Right (Handshake [])) = True isEmptyHandshake _ = False ---------------------------------------------------------------- recvPacket13 :: MonadIO m => Context -> m (Either TLSError Packet13) recvPacket13 ctx = liftIO $ do erecord <- recvRecord13 ctx case erecord of Left err@(Error_Protocol (_, True, BadRecordMac)) -> do -- If the server decides to reject RTT0 data but accepts RTT1 -- data, the server should skip all records for RTT0 data. established <- ctxEstablished ctx case established of EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvPacket13 ctx _ -> return $ Left err Left err -> return $ Left err Right record -> do pktRecv <- processPacket13 ctx record if isEmptyHandshake13 pktRecv then -- When a handshake record is fragmented we continue receiving -- in order to feed stHandshakeRecordCont13 recvPacket13 ctx else do pkt <- case pktRecv of Right (Handshake13 hss) -> ctxWithHooks ctx $ \hooks -> Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss _ -> return pktRecv case pkt of Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p _ -> return () return pkt 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) | readlen > 16384 + 256 = return $ Left maximumSizeExceeded | otherwise = readExactBytes ctx (fromIntegral readlen) >>= either (return . Left) (getRecord ctx 0 header) isEmptyHandshake13 :: Either TLSError Packet13 -> Bool isEmptyHandshake13 (Right (Handshake13 [])) = True isEmptyHandshake13 _ = False ---------------------------------------------------------------- -- Common for receiving maximumSizeExceeded :: TLSError maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) readExactBytes :: Context -> Int -> IO (Either TLSError ByteString) readExactBytes ctx sz = do hdrbs <- contextRecv ctx sz if B.length hdrbs == sz then return $ Right hdrbs else do setEOF ctx return . Left $ if B.null hdrbs then Error_EOF else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) ---------------------------------------------------------------- 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 $ mkIOError eofErrorType "data" Nothing Nothing ---------------------------------------------------------------- -- | 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 a = PacketFlightM (ReaderT (IORef [ByteString]) IO a) deriving (Functor, Applicative, Monad, MonadFail, MonadIO) runPacketFlight :: Context -> PacketFlightM a -> IO a runPacketFlight ctx (PacketFlightM f) = do ref <- newIORef [] finally (runReaderT f ref) $ do st <- readIORef ref unless (null st) $ sendBytes ctx $ B.concat $ reverse st loadPacket13 :: Context -> Packet13 -> PacketFlightM () loadPacket13 ctx pkt = PacketFlightM $ do bs <- writePacketBytes13 ctx pkt ref <- ask liftIO $ modifyIORef ref (bs :) tls-1.5.4/Network/TLS/Cap.hs0000644000000000000000000000064713623162342013654 0ustar0000000000000000-- | -- Module : Network.TLS.Cap -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Cap ( hasHelloExtensions , hasExplicitBlockIV ) where import Network.TLS.Types hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool hasHelloExtensions ver = ver >= SSL3 hasExplicitBlockIV ver = ver >= TLS11 tls-1.5.4/Network/TLS/Compression.hs0000644000000000000000000000514613623162342015451 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Network.TLS.Compression -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Compression ( CompressionC(..) , Compression(..) , CompressionID , nullCompression , NullCompression -- * member redefined for the class abstraction , compressionID , compressionDeflate , compressionInflate -- * helper , compressionIntersectID ) where import Network.TLS.Types (CompressionID) import Network.TLS.Imports import Control.Arrow (first) -- | 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-1.5.4/Network/TLS/Receiving.hs0000644000000000000000000000644313623162342015064 0ustar0000000000000000-- | -- Module : Network.TLS.Receiving -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state -- {-# LANGUAGE FlexibleContexts #-} module Network.TLS.Receiving ( processPacket , decodeRecordM ) where import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.ErrT import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Record import Network.TLS.State import Network.TLS.Struct import Network.TLS.Util import Network.TLS.Wire import Control.Concurrent.MVar import Control.Monad.State.Strict processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) = case decodeChangeCipherSpec $ fragmentGetBytes fragment of Left err -> return $ Left err Right _ -> do switchRxEncryption ctx return $ Right ChangeCipherSpec processPacket ctx (Record ProtocolType_Handshake ver fragment) = do keyxchg <- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg } -- get back the optional continuation, and parse as many handshake record as possible. mCont <- gets stHandshakeRecordCont modify (\st -> st { stHandshakeRecordCont = Nothing }) hss <- parseMany currentParams mCont (fragmentGetBytes fragment) return $ Handshake hss where parseMany currentParams mCont bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont -> modify (\st -> st { stHandshakeRecordCont = Just cont }) >> return [] GotSuccess (ty,content) -> either throwError (return . (:[])) $ decodeHandshake currentParams ty content GotSuccessRemaining (ty,content) left -> case decodeHandshake currentParams ty content of Left err -> throwError err Right hh -> (hh:) <$> parseMany currentParams Nothing left processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) = case decodeDeprecatedHandshake $ fragmentGetBytes fragment of Left err -> return $ Left err Right hs -> return $ Right $ Handshake [hs] switchRxEncryption :: Context -> IO () switchRxEncryption ctx = usingHState ctx (gets hstPendingRxState) >>= \rx -> liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) decodeRecordM :: Header -> ByteString -> RecordM (Record Plaintext) decodeRecordM header content = disengageRecord erecord where erecord = rawToRecord header (fragmentCiphertext content) tls-1.5.4/Network/TLS/Util.hs0000644000000000000000000000705513623162342014066 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Util ( sub , takelast , partition3 , partition6 , fromJust , (&&!) , bytesEq , fmapEither , catchException , forEitherM , mapChunks_ , getChunks , Saved , saveMVar , restoreMVar ) where import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Imports import Control.Exception (SomeException) import Control.Concurrent.Async import Control.Concurrent.MVar 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 fromJust :: String -> Maybe a -> a fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck fromJust _ (Just x) = x -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool True &&! True = True True &&! False = False False &&! True = False False &&! False = False -- | verify that 2 bytestrings are equals. -- it's a non lazy version, that will compare every bytes. -- arguments with different length will bail out early bytesEq :: ByteString -> ByteString -> Bool bytesEq = BA.constEq fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f = fmap f catchException :: IO a -> (SomeException -> IO a) -> IO a catchException action handler = withAsync action waitCatch >>= either handler return 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 => Int -> (B.ByteString -> m a) -> B.ByteString -> m () mapChunks_ len f = mapM_ f . getChunks len getChunks :: Int -> B.ByteString -> [B.ByteString] getChunks len bs | B.length bs > len = let (chunk, remain) = B.splitAt len bs in chunk : getChunks len 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-1.5.4/Network/TLS/RNG.hs0000644000000000000000000000113613623162342013571 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.TLS.RNG ( StateRNG(..) , Seed , seedNew , seedToInteger , seedFromInteger , withTLSRNG , newStateRNG , MonadRandom , getRandomBytes ) where import Crypto.Random.Types 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-1.5.4/Network/TLS/Crypto/0000755000000000000000000000000013623162342014066 5ustar0000000000000000tls-1.5.4/Network/TLS/Crypto/IES.hs0000644000000000000000000002703613623162342015052 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 (os2ip,i2ospOf_) 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 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 -- 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) premaster 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-1.5.4/Network/TLS/Crypto/Types.hs0000644000000000000000000000134213623162342015526 0ustar0000000000000000-- | -- Module : Network.TLS.Crypto.Types -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown -- module Network.TLS.Crypto.Types where data Group = P256 | P384 | P521 | X25519 | X448 | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 deriving (Eq, Show) availableFFGroups :: [Group] availableFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192] availableECGroups :: [Group] availableECGroups = [P256,P384,P521,X25519,X448] -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3). data KeyExchangeSignatureAlg = KX_RSA | KX_DSS | KX_ECDSA deriving (Show, Eq) tls-1.5.4/Network/TLS/Crypto/DH.hs0000644000000000000000000000407713623162342014725 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 qualified Crypto.PubKey.DH as DH import Crypto.Number.Basic (numBits) 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) premaster 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-1.5.4/Network/TLS/Context/0000755000000000000000000000000013623162342014232 5ustar0000000000000000tls-1.5.4/Network/TLS/Context/Internal.hs0000644000000000000000000002716313623162342016353 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Context.Internal -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Context.Internal ( -- * Context configuration ClientParams(..) , ServerParams(..) , defaultParamsClient , SessionID , SessionData(..) , MaxFragmentEnum(..) , Measurement(..) -- * Context object and accessor , Context(..) , Hooks(..) , Established(..) , PendingAction(..) , ctxEOF , ctxHasSSLv2ClientHello , ctxDisableSSLv2ClientHello , ctxEstablished , withLog , ctxWithHooks , contextModifyHooks , setEOF , setEstablished , contextFlush , contextClose , contextSend , contextRecv , updateMeasure , withMeasure , withReadLock , withWriteLock , withStateLock , withRWLock -- * information , Information(..) , contextGetInformation -- * Using context states , throwCore , failOnEitherError , usingState , usingState_ , runTxState , runRxState , usingHState , getHState , saveHState , restoreHState , getStateRNG , tls13orLater , addCertRequest13 , getCertRequest13 , decideRecordVersion ) where import Network.TLS.Backend import Network.TLS.Extension import Network.TLS.Cipher import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Compression (Compression) import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Hooks import Network.TLS.Record.State import Network.TLS.Parameters import Network.TLS.Measurement import Network.TLS.Imports import Network.TLS.Types import Network.TLS.Util import qualified Data.ByteString as B import Control.Concurrent.MVar import Control.Monad.State.Strict import Control.Exception (throwIO, Exception()) import Data.IORef import Data.Tuple -- | Information related to a running context, e.g. current cipher data Information = Information { infoVersion :: Version , infoCipher :: Cipher , infoCompression :: Compression , infoMasterSecret :: Maybe ByteString , infoExtendedMasterSec :: Bool , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom , infoNegotiatedGroup :: Maybe Group , infoTLS13HandshakeMode :: Maybe HandshakeMode13 , infoIsEarlyDataAccepted :: Bool } deriving (Show,Eq) -- | A TLS Context keep tls specific state, parameters and backend information. data Context = Context { ctxConnection :: Backend -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared , ctxState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful. , ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability. , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. -- the flag will be set to false regardless of its initial value -- after the first packet received. , ctxTxState :: MVar RecordState -- ^ current tx state , ctxRxState :: MVar RecordState -- ^ current rx state , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state , ctxDoHandshake :: Context -> IO () , ctxDoHandshakeWith :: Context -> Handshake -> IO () , ctxDoRequestCertificate :: Context -> IO Bool , ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO () , ctxHooks :: IORef Hooks -- ^ hooks for this context , ctxLockWrite :: MVar () -- ^ lock to use for writing data (including updating the state) , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. -- it is usually nested in a write or read lock. , ctxPendingActions :: IORef [PendingAction] , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests , ctxKeyLogger :: String -> IO () } data Established = NotEstablished | EarlyDataAllowed Int -- remaining 0-RTT bytes allowed | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip | Established deriving (Eq, Show) data PendingAction = PendingAction Bool (Handshake13 -> IO ()) -- ^ simple pending action | PendingActionHash Bool (ByteString -> Handshake13 -> IO ()) -- ^ pending action taking transcript hash up to preceding message updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx f = do x <- readIORef (ctxMeasurement ctx) writeIORef (ctxMeasurement ctx) $! f x withMeasure :: Context -> (Measurement -> IO a) -> IO a withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f -- | A shortcut for 'backendFlush . ctxConnection'. contextFlush :: Context -> IO () contextFlush = backendFlush . ctxConnection -- | A shortcut for 'backendClose . ctxConnection'. contextClose :: Context -> IO () contextClose = backendClose . ctxConnection -- | 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 -> (hstMasterSecret st, hstExtendedMasterSec st, Just (hstClientRandom st), hstServerRandom st, if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing, hstNegotiatedGroup st) Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing) (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st) let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False case (ver, cipher) of (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted _ -> return Nothing contextSend :: Context -> ByteString -> IO () contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b contextRecv :: Context -> Int -> IO ByteString contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz ctxEOF :: Context -> IO Bool ctxEOF ctx = readIORef $ ctxEOF_ ctx ctxHasSSLv2ClientHello :: Context -> IO Bool ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx ctxDisableSSLv2ClientHello :: Context -> IO () ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True 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, Exception e) => e -> m a throwCore = liftIO . throwIO 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 (ctxState ctx) $ \st -> let (a, newst) = runTLSState f st in newst `seq` return (newst, a) usingState_ :: Context -> TLSSt a -> IO a usingState_ ctx f = failOnEitherError $ usingState ctx f usingHState :: MonadIO m => Context -> HandshakeM a -> m a usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> case mst of Nothing -> throwCore $ Error_Misc "missing handshake" Just st -> return $ swap (Just <$> runHandshake st f) getHState :: MonadIO m => Context -> m (Maybe HandshakeState) getHState ctx = liftIO $ readMVar (ctxHandshake ctx) saveHState :: Context -> IO (Saved (Maybe HandshakeState)) saveHState ctx = saveMVar (ctxHandshake ctx) restoreHState :: Context -> Saved (Maybe HandshakeState) -> IO (Saved (Maybe HandshakeState)) restoreHState ctx = restoreMVar (ctxHandshake ctx) decideRecordVersion :: Context -> IO (Version, Bool) decideRecordVersion ctx = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) hrr <- usingState_ ctx 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) runTxState :: Context -> RecordM a -> IO (Either TLSError a) runTxState ctx f = do (ver, tls13) <- decideRecordVersion ctx let opt = RecordOptions { recordVersion = ver , recordTLS13 = tls13 } modifyMVar (ctxTxState ctx) $ \st -> case runRecordM f opt st of Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) runRxState :: Context -> RecordM a -> IO (Either TLSError a) runRxState ctx f = do ver <- usingState_ ctx getVersion -- For 1.3, ver is just ignored. So, it is not necessary to convert ver. let opt = RecordOptions { recordVersion = ver , recordTLS13 = ver >= TLS13 } modifyMVar (ctxRxState ctx) $ \st -> 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 (ctxLockRead ctx) (const f) withWriteLock :: Context -> IO a -> IO a withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f) withRWLock :: Context -> IO a -> IO a withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f withStateLock :: Context -> IO a -> IO a withStateLock ctx f = withMVar (ctxLockState ctx) (const f) tls13orLater :: MonadIO m => Context -> m Bool tls13orLater ctx = do ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme 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 (\(CertRequest13 c _) -> context == c) l case matched of [] -> return Nothing (certReq:_) -> writeIORef ref others >> return (Just certReq) tls-1.5.4/Network/TLS/Record/0000755000000000000000000000000013623162342014024 5ustar0000000000000000tls-1.5.4/Network/TLS/Record/State.hs0000644000000000000000000001134013623162342015437 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Record.State -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Record.State ( CryptState(..) , MacState(..) , RecordOptions(..) , RecordState(..) , newRecordState , incrRecordState , RecordM , runRecordM , getRecordOptions , getRecordVersion , setRecordIV , withCompression , computeDigest , makeDigest , getBulk , getMacSequence ) where import Control.Monad.State.Strict import Network.TLS.Compression import Network.TLS.Cipher import Network.TLS.ErrT import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.MAC import Network.TLS.Util import Network.TLS.Imports import qualified Data.ByteString as B 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 } data RecordState = RecordState { stCipher :: Maybe Cipher , stCompression :: Compression , stCryptState :: !CryptState , stMacState :: !MacState } deriving (Show) newtype RecordM a = RecordM { runRecordM :: RecordOptions -> RecordState -> Either TLSError (a, RecordState) } instance Applicative RecordM where pure = return (<*>) = ap instance Monad RecordM where return a = RecordM $ \_ st -> Right (a, st) m1 >>= m2 = RecordM $ \opt st -> case runRecordM m1 opt st of Left err -> Left err Right (a, st2) -> runRecordM (m2 a) opt st2 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) #if MIN_VERSION_mtl(2,1,0) state f = RecordM $ \_ st -> Right (f st) #endif 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 , 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 "cipher" $ stCipher tstate hashA = cipherHash cipher encodedSeq = encodeWord64 $ msSequence $ stMacState tstate (macF, msg) | ver < TLS10 = (macSSL hashA, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ]) | otherwise = (hmac hashA, B.concat [ encodedSeq, encodeHeader hdr, content ]) 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 "cipher" . stCipher <$> get getMacSequence :: RecordM Word64 getMacSequence = msSequence . stMacState <$> get tls-1.5.4/Network/TLS/Record/Engage.hs0000644000000000000000000001300113623162342015541 0ustar0000000000000000-- | -- Module : Network.TLS.Record.Engage -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Engage a record into the Record layer. -- The record is compressed, added some integrity field, then encrypted. -- -- Starting with TLS v1.3, only the "null" compression method is negotiated in -- the handshake, so the compression step will be a no-op. Integrity and -- encryption are performed using an AEAD cipher only. -- {-# LANGUAGE BangPatterns #-} module Network.TLS.Record.Engage ( engageRecord ) where import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Cap import Network.TLS.Record.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.Struct import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert, xor) engageRecord :: Record Plaintext -> RecordM (Record Ciphertext) engageRecord = compressRecord >=> encryptRecord compressRecord :: Record Plaintext -> RecordM (Record Compressed) compressRecord record = onRecordFragment record $ fragmentCompress $ \bytes -> do withCompression $ compressionDeflate bytes -- when Tx Encrypted is set, we pass the data through encryptContent, otherwise -- we just return the compress payload directly as the ciphered one -- encryptRecord :: Record Compressed -> RecordM (Record Ciphertext) encryptRecord record@(Record ct ver fragment) = do st <- get case stCipher st of Nothing -> noEncryption _ -> do recOpts <- getRecordOptions if recordTLS13 recOpts then encryptContent13 else onRecordFragment record $ fragmentCipher (encryptContent False record) where noEncryption = onRecordFragment record $ fragmentCipher return encryptContent13 | ct == ProtocolType_ChangeCipherSpec = noEncryption | otherwise = do let bytes = fragmentGetBytes fragment fragment' = fragmentCompressed $ innerPlaintext ct bytes record' = Record ProtocolType_AppData ver fragment' onRecordFragment record' $ fragmentCipher (encryptContent True record') innerPlaintext :: ProtocolType -> ByteString -> ByteString innerPlaintext ct bytes = runPut $ do putBytes bytes putWord8 $ valOfType ct -- non zero! -- fixme: zeros padding encryptContent :: Bool -> Record Compressed -> ByteString -> RecordM ByteString encryptContent tls13 record content = do cst <- getCryptState bulk <- getBulk case cstKey cst of BulkStateBlock encryptF -> do digest <- makeDigest (recordToHeader record) content let content' = B.concat [content, digest] encryptBlock encryptF content' bulk BulkStateStream encryptF -> do digest <- makeDigest (recordToHeader record) content let content' = B.concat [content, digest] encryptStream encryptF content' BulkStateAEAD encryptF -> encryptAead tls13 bulk encryptF content record BulkStateUninitialized -> return content encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString encryptBlock encryptF content bulk = do cst <- getCryptState ver <- getRecordVersion let blockSize = fromIntegral $ bulkBlockSize bulk let msg_len = B.length content let padding = if blockSize > 0 then let padbyte = blockSize - (msg_len `mod` blockSize) in let padbyte' = if padbyte == 0 then blockSize else padbyte in B.replicate padbyte' (fromIntegral (padbyte' - 1)) else B.empty let (e, iv') = encryptF (cstIV cst) $ B.concat [ content, padding ] if hasExplicitBlockIV ver then return $ B.concat [cstIV cst,e] else do modify $ \tstate -> tstate { stCryptState = cst { cstIV = iv' } } return e encryptStream :: BulkStream -> ByteString -> RecordM ByteString encryptStream (BulkStream encryptF) content = do cst <- getCryptState let (!e, !newBulkStream) = encryptF content modify $ \tstate -> tstate { stCryptState = cst { cstKey = BulkStateStream newBulkStream } } return e encryptAead :: Bool -> Bulk -> BulkAEAD -> ByteString -> Record Compressed -> RecordM ByteString encryptAead tls13 bulk encryptF content record = do let authTagLen = bulkAuthTagLen bulk nonceExpLen = bulkExplicitIV bulk cst <- getCryptState encodedSeq <- encodeWord64 <$> getMacSequence let iv = cstIV cst ivlen = B.length iv Header typ v plainLen = recordToHeader record hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen hdr = Header typ v hdrLen ad | tls13 = encodeHeader hdr | otherwise = B.concat [ encodedSeq, encodeHeader hdr ] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce | nonceExpLen == 0 = B.xor iv sqnc | otherwise = B.concat [iv, encodedSeq] (e, AuthTag authtag) = encryptF nonce content ad econtent | nonceExpLen == 0 = e `B.append` B.convert authtag | otherwise = B.concat [encodedSeq, e, B.convert authtag] modify incrRecordState return econtent getCryptState :: RecordM CryptState getCryptState = stCryptState <$> get tls-1.5.4/Network/TLS/Record/Types.hs0000644000000000000000000000672213623162342015473 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Record.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- The Record Protocol takes messages to be transmitted, fragments the -- data into manageable blocks, optionally compresses the data, applies -- a MAC, encrypts, and transmits the result. Received data is -- decrypted, verified, decompressed, reassembled, and then delivered to -- higher-level clients. -- module Network.TLS.Record.Types ( Header(..) , ProtocolType(..) , packetType -- * TLS Records , Record(..) -- * TLS Record fragment and constructors , Fragment , fragmentGetBytes , fragmentPlaintext , fragmentCompressed , fragmentCiphertext , Plaintext , Compressed , Ciphertext -- * manipulate record , onRecordFragment , fragmentCompress , fragmentCipher , fragmentUncipher , fragmentUncompress -- * serialize record , rawToRecord , recordToRaw , recordToHeader ) where import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Record.State import qualified Data.ByteString as B -- | 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 Compressed data Ciphertext fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes fragmentCompressed :: ByteString -> Fragment Compressed fragmentCompressed bytes = Fragment bytes fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record 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 plaintext record into a compressed record using the compression function supplied fragmentCompress :: (ByteString -> RecordM ByteString) -> Fragment Plaintext -> RecordM (Fragment Compressed) fragmentCompress f = fragmentMap f -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (ByteString -> RecordM ByteString) -> Fragment Compressed -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext -> RecordM (Fragment Compressed) fragmentUncipher f = fragmentMap f -- | turn a compressed fragment into a plaintext fragment using the decompression function supplied fragmentUncompress :: (ByteString -> RecordM ByteString) -> Fragment Compressed -> RecordM (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, ByteString) 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-1.5.4/Network/TLS/Record/Disengage.hs0000644000000000000000000002137713623162342016260 0ustar0000000000000000-- | -- Module : Network.TLS.Record.Disengage -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Disengage a record from the Record layer. -- The record is decrypted, checked for integrity and then decompressed. -- -- Starting with TLS v1.3, only the "null" compression method is negotiated in -- the handshake, so the decompression step will be a no-op. Decryption and -- integrity verification are performed using an AEAD cipher only. -- {-# LANGUAGE FlexibleContexts #-} module Network.TLS.Record.Disengage ( disengageRecord ) where import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Struct import Network.TLS.ErrT import Network.TLS.Cap import Network.TLS.Record.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Crypto import Network.TLS.Compression import Network.TLS.Util import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert, xor) disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext) disengageRecord = decryptRecord >=> uncompressRecord uncompressRecord :: Record Compressed -> RecordM (Record Plaintext) uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes -> withCompression $ compressionInflate bytes decryptRecord :: Record Ciphertext -> RecordM (Record Compressed) decryptRecord record@(Record ct ver fragment) = do st <- get case stCipher st of Nothing -> noDecryption _ -> do recOpts <- getRecordOptions let mver = recordVersion recOpts if recordTLS13 recOpts then decryptData13 mver (fragmentGetBytes fragment) st else onRecordFragment record $ fragmentUncipher $ \e -> decryptData mver record e st where noDecryption = onRecordFragment record $ fragmentUncipher return decryptData13 mver e st | ct == ProtocolType_AppData = do inner <- decryptData mver record e st case unInnerPlaintext inner of Left message -> throwError $ Error_Protocol (message, True, UnexpectedMessage) Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d) | otherwise = noDecryption unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString) unInnerPlaintext inner = case B.unsnoc dc of Nothing -> Left $ unknownContentType13 (0 :: Word8) Just (bytes,c) -> case valToType c of Nothing -> Left $ unknownContentType13 c Just ct | B.null bytes && ct `elem` nonEmptyContentTypes -> Left ("empty " ++ show ct ++ " record disallowed") | otherwise -> Right (ct, bytes) where (dc,_pad) = B.spanEnd (== 0) inner nonEmptyContentTypes = [ ProtocolType_Handshake, ProtocolType_Alert ] unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c getCipherData :: Record a -> CipherData -> RecordM ByteString getCipherData (Record pt ver _) cdata = do -- check if the MAC is valid. macValid <- case cipherDataMAC cdata of Nothing -> return True Just digest -> do let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) expected_digest <- makeDigest new_hdr $ cipherDataContent cdata return (expected_digest `bytesEq` digest) -- check if the padding is filled with the correct pattern if it exists -- (before TLS10 this checks instead that the padding length is minimal) paddingValid <- case cipherDataPadding cdata of Nothing -> return True Just (pad, blksz) -> do cver <- getRecordVersion let b = B.length pad - 1 return $ if cver < TLS10 then b < blksz else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad unless (macValid &&! paddingValid) $ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) return $ cipherDataContent cdata decryptData :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString decryptData ver record econtent tst = decryptOf (cstKey cst) where cipher = fromJust "cipher" $ stCipher tst bulk = cipherBulk cipher cst = stCryptState tst macSize = hashDigestSize $ cipherHash cipher blockSize = bulkBlockSize bulk econtentLen = B.length econtent explicitIV = hasExplicitBlockIV ver sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") decryptOf :: BulkState -> RecordM ByteString decryptOf (BulkStateBlock decryptF) = do let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize -- check if we have enough bytes to cover the minimum for this cipher when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) sanityCheckError {- update IV -} (iv, econtent') <- if explicitIV then get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk) else return (cstIV cst, econtent) let (content', iv') = decryptF iv econtent' modify $ \txs -> txs { stCryptState = cst { cstIV = iv' } } let paddinglength = fromIntegral (B.last content') + 1 let contentlen = B.length content' - paddinglength - macSize (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength) getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Just (padding, blockSize) } decryptOf (BulkStateStream (BulkStream decryptF)) = do -- check if we have enough bytes to cover the minimum for this cipher when (econtentLen < macSize) sanityCheckError let (content', bulkStream') = decryptF econtent {- update Ctx -} let contentlen = B.length content' - macSize (content, mac) <- get2i content' (contentlen, macSize) modify $ \txs -> txs { stCryptState = cst { cstKey = BulkStateStream bulkStream' } } getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Nothing } decryptOf (BulkStateAEAD decryptF) = do let authTagLen = bulkAuthTagLen bulk nonceExpLen = bulkExplicitIV bulk cipherLen = econtentLen - authTagLen - nonceExpLen -- check if we have enough bytes to cover the minimum for this cipher when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError (enonce, econtent', authTag) <- get3o econtent (nonceExpLen, cipherLen, authTagLen) let encodedSeq = encodeWord64 $ msSequence $ stMacState tst iv = cstIV (stCryptState tst) ivlen = B.length iv Header typ v _ = recordToHeader record hdrLen = if ver >= TLS13 then econtentLen else cipherLen hdr = Header typ v $ fromIntegral hdrLen ad | ver >= TLS13 = encodeHeader hdr | otherwise = B.concat [ encodedSeq, encodeHeader hdr ] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce | nonceExpLen == 0 = B.xor iv sqnc | otherwise = iv `B.append` enonce (content, authTag2) = decryptF nonce econtent' ad when (AuthTag (B.convert authTag) /= authTag2) $ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) modify incrRecordState return content decryptOf BulkStateUninitialized = throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError) -- handling of outer format can report errors with Error_Packet get3o s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls get2o s (d1,d2) = get3o s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) -- all format errors related to decrypted content are reported -- externally as integrity failures, i.e. BadRecordMac get3i s ls = maybe (throwError $ Error_Protocol ("record bad format", True, BadRecordMac)) return $ partition3 s ls get2i s (d1,d2) = get3i s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) tls-1.5.4/Network/TLS/Util/0000755000000000000000000000000013623162342013523 5ustar0000000000000000tls-1.5.4/Network/TLS/Util/ASN1.hs0000644000000000000000000000230313623162342014557 0ustar0000000000000000-- | -- Module : Network.TLS.Util.ASN1 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- ASN1 utils for TLS -- module Network.TLS.Util.ASN1 ( decodeASN1Object , encodeASN1Object ) where import Network.TLS.Imports import Data.ASN1.Types (fromASN1, toASN1, ASN1Object) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..)) -- | 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-1.5.4/Network/TLS/Util/Serialization.hs0000644000000000000000000000022213623162342016670 0ustar0000000000000000module Network.TLS.Util.Serialization ( os2ip , i2osp , i2ospOf_ ) where import Crypto.Number.Serialize (os2ip, i2osp, i2ospOf_) tls-1.5.4/Network/TLS/Handshake/0000755000000000000000000000000013623162342014474 5ustar0000000000000000tls-1.5.4/Network/TLS/Handshake/Process.hs0000644000000000000000000001506613623162342016456 0ustar0000000000000000-- | -- Module : Network.TLS.Handshake.Process -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- process handshake message received -- module Network.TLS.Handshake.Process ( processHandshake , processHandshake13 , startHandshake ) where import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.Sending import Network.TLS.Sending13 import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types (Role(..), invertRole, MasterSecret(..)) import Network.TLS.Util import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (gets) import Data.X509 (CertificateChain(..), Certificate(..), getCertificate) processHandshake :: Context -> Handshake -> IO () processHandshake ctx hs = do role <- usingState_ ctx isClientContext case hs of ClientHello cver ran _ cids _ ex _ -> when (role == ServerRole) $ do mapM_ (usingState_ ctx . processClientExtension) ex -- RFC 5746: secure renegotiation -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} when (secureRenegotiation && (0xff `elem` cids)) $ usingState_ ctx $ setSecureRenegotiation True hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx cver ran Certificates certs -> processCertificates role certs Finished fdata -> processClientFinished ctx fdata _ -> return () when (isHRR hs) $ usingHState ctx wrapAsMessageHash13 void $ updateHandshake ctx ServerRole hs case hs of ClientKeyXchg content -> when (role == ServerRole) $ processClientKeyXchg ctx content _ -> return () where secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx -- RFC5746: secure renegotiation -- the renegotiation_info extension: 0xff01 processClientExtension (ExtensionRaw 0xff01 content) | secureRenegotiation = do v <- getVerifiedData ClientRole let bs = extensionEncode (SecureRenegotiation v Nothing) unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure) setSecureRenegotiation True -- unknown extensions processClientExtension _ = return () processCertificates :: Role -> CertificateChain -> IO () processCertificates ServerRole (CertificateChain []) = return () processCertificates ClientRole (CertificateChain []) = throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure) processCertificates _ (CertificateChain (c:_)) = usingHState ctx $ setPublicKey pubkey where pubkey = certPubKey $ getCertificate c isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand isHRR _ = False processHandshake13 :: Context -> Handshake13 -> IO () processHandshake13 ctx = void . updateHandshake13 ctx -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negotiated version. -- in case the version mismatch, generate a random master secret processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO () processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do (rver, role, random) <- usingState_ ctx $ do (,,) <$> getVersion <*> isClientContext <*> genRandom 48 ePremaster <- decryptRSA ctx encryptedPremaster masterSecret <- usingHState ctx $ do expectedVer <- gets hstClientVersion case ePremaster of Left _ -> setMasterSecretFromPre rver role random Right premaster -> case decodePreMasterSecret premaster of Left _ -> setMasterSecretFromPre rver role random Right (ver, _) | ver /= expectedVer -> setMasterSecretFromPre rver role random | otherwise -> setMasterSecretFromPre rver role premaster liftIO $ logKey ctx (MasterSecret masterSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext serverParams <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams unless (dhValid params $ dhUnwrapPublic clientDHValue) $ throwCore $ Error_Protocol ("invalid client public key", True, IllegalParameter) dhpriv <- usingHState ctx getDHPrivate let premaster = dhGetShared params dhpriv clientDHValue masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster liftIO $ logKey ctx (MasterSecret masterSecret) processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams case decodeGroupPublic grp bytes of Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, IllegalParameter) Right clipub -> do srvpri <- usingHState ctx getGroupPrivate case groupGetShared clipub srvpri of Just premaster -> do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster liftIO $ logKey ctx (MasterSecret masterSecret) Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on ECDH", True, IllegalParameter) processClientFinished :: Context -> FinishedData -> IO () processClientFinished ctx fdata = do (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc when (expected /= fdata) $ decryptError "cannot verify finished" -- initialize a new Handshake context (initial handshake or renegotiations) startHandshake :: Context -> Version -> ClientRandom -> IO () startHandshake ctx ver crand = let hs = Just $ newEmptyHandshake ver crand in liftIO $ void $ swapMVar (ctxHandshake ctx) hs tls-1.5.4/Network/TLS/Handshake/Common.hs0000644000000000000000000002373513623162342016272 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Common ( handshakeFailed , handleException , unexpected , newSession , handshakeTerminate -- * sending packets , sendChangeCipherAndFinish -- * receiving packets , recvChangeCipherAndFinish , RecvState(..) , runRecvState , recvPacketHandshake , onRecvStateHandshake , ensureRecvComplete , processExtendedMasterSec , extensionLookup , getSessionData , storePrivInfo , isSupportedGroup , checkSupportedGroup ) where import qualified Data.ByteString as B import Control.Concurrent.MVar import Network.TLS.Parameters import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Extension import Network.TLS.Session import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.IO import Network.TLS.State import Network.TLS.Handshake.Key import Network.TLS.Handshake.Process import Network.TLS.Handshake.State import Network.TLS.Record.State import Network.TLS.Measurement import Network.TLS.Types import Network.TLS.Cipher import Network.TLS.Crypto import Network.TLS.Util import Network.TLS.X509 import Network.TLS.Imports import Control.Monad.State.Strict import Control.Exception (IOException, handle, fromException, throwIO) handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception setEstablished ctx NotEstablished handle ignoreIOErr $ do tls13 <- tls13orLater ctx if tls13 then sendPacket13 ctx $ Alert13 $ errorToAlert tlserror else sendPacket 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_Packet_unexpected _ _) = [(AlertLevel_Fatal, UnexpectedMessage)] errorToAlert (Error_Packet_Parsing _) = [(AlertLevel_Fatal, DecodeError)] errorToAlert _ = [(AlertLevel_Fatal, InternalError)] 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. handshakeTerminate :: Context -> IO () handshakeTerminate ctx = do session <- usingState_ ctx getSession -- only callback the session established if we have a session case session of Session (Just sessionId) -> do sessionData <- getSessionData ctx let !sessionId' = B.copy sessionId liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId' (fromJust "session-data" sessionData) _ -> return () -- forget most handshake data and reset bytes counters. liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake -> case mhshake of Nothing -> return Nothing Just hshake -> return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) { hstServerRandom = hstServerRandom hshake , hstMasterSecret = hstMasterSecret hshake , hstExtendedMasterSec = hstExtendedMasterSec hshake , hstNegotiatedGroup = hstNegotiatedGroup hshake } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. setEstablished ctx Established return () sendChangeCipherAndFinish :: Context -> Role -> IO () sendChangeCipherAndFinish ctx role = do sendPacket ctx ChangeCipherSpec liftIO $ contextFlush ctx cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role sendPacket ctx (Handshake [Finished cf]) liftIO $ contextFlush ctx recvChangeCipherAndFinish :: Context -> IO () recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher) where expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") data RecvState m = RecvStateNext (Packet -> m (RecvState m)) | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone recvPacketHandshake :: Context -> IO [Handshake] recvPacketHandshake ctx = do pkts <- recvPacket 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 _ (RecvStateNext f) hms = f (Handshake hms) onRecvStateHandshake ctx (RecvStateHandshake f) (x:xs) = do nstate <- f x processHandshake ctx x onRecvStateHandshake ctx nstate xs onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing runRecvState :: Context -> RecvState IO -> IO () runRecvState _ RecvStateDone = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do complete <- liftIO $ isRecvComplete ctx unless complete $ throwCore $ Error_Protocol ("received incomplete message at key change", True, UnexpectedMessage) processExtendedMasterSec :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool processExtendedMasterSec ctx ver msgt exts | ver < TLS10 = return False | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" | ems == NoEMS = return False | otherwise = case extensionLookup extensionID_ExtendedMasterSecret exts >>= extensionDecode msgt of Just ExtendedMasterSecret -> usingHState ctx (setExtendedMasterSec True) >> return True Nothing | ems == RequireEMS -> throwCore $ Error_Protocol (err, True, HandshakeFailure) | otherwise -> return False where ems = supportedExtendedMasterSec (ctxSupported ctx) err = "peer does not support Extended Master Secret" getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do ver <- usingState_ ctx getVersion sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) !ems <- usingHState ctx getExtendedMasterSec tx <- liftIO $ readMVar (ctxTxState ctx) alpn <- usingState_ ctx getNegotiatedProtocol let !cipher = cipherID $ fromJust "cipher" $ stCipher tx !compression = compressionID $ stCompression tx 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 } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString extensionLookup toFind = fmap (\(ExtensionRaw _ content) -> content) . find (\(ExtensionRaw eid _) -> eid == toFind) -- | Store the specified keypair. Whether the public key and private key -- actually match is left for the peer to discover. We're not presently -- burning CPU to detect that misconfiguration. We verify only that the -- types of keys match. storePrivInfo :: MonadIO m => Context -> CertificateChain -> PrivKey -> m PubKey storePrivInfo ctx cc privkey = do let CertificateChain (c:_) = cc pubkey = certPubKey $ getCertificate c unless (isDigitalSignaturePair (pubkey, privkey)) $ throwCore $ Error_Protocol ( "mismatched or unsupported private key pair" , True , InternalError ) usingHState ctx $ setPublicPrivateKeys (pubkey, privkey) return pubkey -- 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, True, IllegalParameter) isSupportedGroup :: Context -> Group -> Bool isSupportedGroup ctx grp = grp `elem` supportedGroups (ctxSupported ctx) tls-1.5.4/Network/TLS/Handshake/State.hs0000644000000000000000000005322013623162342016112 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Handshake.State -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.State ( HandshakeState(..) , HandshakeDigest(..) , HandshakeMode13(..) , RTT0Status(..) , CertReqCBdata , HandshakeM , newEmptyHandshake , runHandshake -- * 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 -- * master secret , setMasterSecret , setMasterSecretFromPre -- * misc accessor , getPendingCipher , setServerHelloParameters , setExtendedMasterSec , getExtendedMasterSec , setNegotiatedGroup , getNegotiatedGroup , setTLS13HandshakeMode , getTLS13HandshakeMode , setTLS13RTT0Status , getTLS13RTT0Status , setTLS13EarlySecret , getTLS13EarlySecret , setTLS13ResumptionSecret , getTLS13ResumptionSecret , setCCS13Sent , getCCS13Sent ) where import Network.TLS.Util import Network.TLS.Struct import Network.TLS.Record.State import Network.TLS.Packet import Network.TLS.Crypto import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Types import Network.TLS.Imports import Control.Monad.State.Strict import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) 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) , hstMasterSecret :: !(Maybe ByteString) , hstKeyState :: !HandshakeKeyState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams) , hstGroupPrivate :: !(Maybe GroupPrivate) , hstHandshakeDigest :: !HandshakeDigest , hstHandshakeMessages :: [ByteString] , hstCertReqToken :: !(Maybe ByteString) -- ^ Set to Just-value when a TLS13 certificate request is received , hstCertReqCBdata :: !(Maybe CertReqCBdata) -- ^ Set to Just-value when a certificate request is received , hstCertReqSigAlgsCert :: !(Maybe [HashAndSignatureAlgorithm]) -- ^ In TLS 1.3, these are separate from the certificate -- issuer signature algorithm hints in the callback data. -- In TLS 1.2 the same list is overloaded for both purposes. -- Not present in TLS 1.1 and earlier , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent. This applies -- only to requests sent during handshake (not post-handshake). , hstClientCertChain :: !(Maybe CertificateChain) , hstPendingTxState :: Maybe RecordState , hstPendingRxState :: Maybe RecordState , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression , hstExtendedMasterSec :: Bool , hstNegotiatedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: !RTT0Status , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) , hstCCS13Sent :: !Bool } deriving (Show) {- | When we receive a CertificateRequest from a server, a just-in-time callback is issued to the application to obtain a suitable certificate. Somewhat unfortunately, the callback parameters don't abstract away the details of the TLS 1.2 Certificate Request message, which combines the legacy @certificate_types@ and new @supported_signature_algorithms@ parameters is a rather subtle way. TLS 1.2 also (again unfortunately, in the opinion of the author of this comment) overloads the signature algorithms parameter to constrain not only the algorithms used in TLS, but also the algorithms used by issuing CAs in the X.509 chain. Best practice is to NOT treat such that restriction as a MUST, but rather take it as merely a preference, when a choice exists. If the best chain available does not match the provided signature algorithm list, go ahead and use it anyway, it will probably work, and the server may not even care about the issuer CAs at all, it may be doing DANE or have explicit mappings for the client's public key, ... The TLS 1.3 @CertificateRequest@ message, drops @certificate_types@ and no longer overloads @supported_signature_algorithms@ to cover X.509. It also includes a new opaque context token that the client must echo back, which makes certain client authentication replay attacks more difficult. We will store that context separately, it does not need to be presented in the user callback. The certificate signature algorithms preferred by the peer are now in the separate @signature_algorithms_cert@ extension, but we cannot report these to the application callback without an API change. The good news is that filtering the X.509 signature types is generally unnecessary, unwise and difficult. So we just ignore this extension. As a result, the information we provide to the callback is no longer a verbatim copy of the certificate request payload. In the case of TLS 1.3 The 'CertificateType' list is synthetically generated from the server's @signature_algorithms@ extension, and the @signature_algorithms_certs@ extension is ignored. 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 #if MIN_VERSION_mtl(2,1,0) state f = HandshakeM (state f) #endif -- create a new empty handshake state newEmptyHandshake :: Version -> ClientRandom -> HandshakeState newEmptyHandshake ver crand = HandshakeState { hstClientVersion = ver , hstClientRandom = crand , hstServerRandom = Nothing , hstMasterSecret = Nothing , hstKeyState = HandshakeKeyState Nothing Nothing , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing , hstGroupPrivate = Nothing , hstHandshakeDigest = HandshakeMessages [] , hstHandshakeMessages = [] , hstCertReqToken = Nothing , hstCertReqCBdata = Nothing , hstCertReqSigAlgsCert = Nothing , hstClientCertSent = False , hstCertReqSent = False , hstClientCertChain = Nothing , hstPendingTxState = Nothing , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression , hstExtendedMasterSec = False , hstNegotiatedGroup = Nothing , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None , hstTLS13EarlySecret = Nothing , hstTLS13ResumptionSecret = Nothing , hstCCS13Sent = False } 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 "remote public key" <$> gets (hksRemotePublicKey . hstKeyState) getLocalPublicPrivateKeys :: HandshakeM (PubKey, PrivKey) getLocalPublicPrivateKeys = fromJust "local public/private key" <$> gets (hksLocalPublicPrivateKeys . hstKeyState) setServerDHParams :: ServerDHParams -> HandshakeM () setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust "server DH params" <$> gets hstServerDHParams setServerECDHParams :: ServerECDHParams -> HandshakeM () setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp }) getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust "server ECDH params" <$> gets hstServerECDHParams setDHPrivate :: DHPrivate -> HandshakeM () setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp }) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate getGroupPrivate :: HandshakeM GroupPrivate getGroupPrivate = fromJust "server ECDH private" <$> gets hstGroupPrivate setGroupPrivate :: GroupPrivate -> HandshakeM () setGroupPrivate shp = modify (\hst -> hst { hstGroupPrivate = Just shp }) setExtendedMasterSec :: Bool -> HandshakeM () setExtendedMasterSec b = modify (\hst -> hst { hstExtendedMasterSec = b }) getExtendedMasterSec :: HandshakeM Bool getExtendedMasterSec = gets hstExtendedMasterSec setNegotiatedGroup :: Group -> HandshakeM () setNegotiatedGroup g = modify (\hst -> hst { hstNegotiatedGroup = Just g }) getNegotiatedGroup :: HandshakeM (Maybe Group) getNegotiatedGroup = gets hstNegotiatedGroup -- | 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 reuest. | 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 setCCS13Sent :: Bool -> HandshakeM () setCCS13Sent sent = modify (\hst -> hst { hstCCS13Sent = sent }) getCCS13Sent :: HandshakeM Bool getCCS13Sent = gets hstCCS13Sent 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 "pending cipher" <$> 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 "master secret" $ hstMasterSecret hst cipher = fromJust "cipher" $ hstPendingCipher hst in generateFinish ver cipher msecret hashCtx HandshakeMessages _ -> error "un-initialized handshake digest" generateFinish | role == ClientRole = generateClientFinished | otherwise = generateServerFinished -- | Generate the master secret from the pre master secret. setMasterSecretFromPre :: ByteArrayAccess preMaster => Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side -> preMaster -- ^ the pre master secret -> HandshakeM ByteString setMasterSecretFromPre ver role premasterSecret = do ems <- getExtendedMasterSec secret <- if ems then get >>= genExtendedSecret else genSecret <$> get setMasterSecret ver role secret return secret where genSecret hst = generateMasterSecret ver (fromJust "cipher" $ hstPendingCipher hst) premasterSecret (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) genExtendedSecret hst = generateExtendedMasterSec ver (fromJust "cipher" $ hstPendingCipher hst) premasterSecret <$> getSessionHash -- | Set master secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. setMasterSecret :: Version -> Role -> ByteString -> HandshakeM () setMasterSecret ver role masterSecret = modify $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role in hst { hstMasterSecret = Just masterSecret , hstPendingTxState = Just pendingTx , hstPendingRxState = Just pendingRx } computeKeyBlock :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust "cipher" $ hstPendingCipher hst keyblockSize = cipherKeyBlockSize cipher bulk = cipherBulk cipher digestSize = if hasMAC (bulkF bulk) then hashDigestSize (cipherHash cipher) else 0 keySize = bulkKeySize bulk ivSize = bulkIVSize bulk kb = generateKeyBlock ver cipher (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) masterSecret keyblockSize (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) 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 , stCipher = Just cipher , stCompression = hstPendingCompression hst } pendingRx = RecordState { stCryptState = if cc == ClientRole then cstServer else cstClient , stMacState = if cc == ClientRole then msServer else msClient , 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-1.5.4/Network/TLS/Handshake/Signature.hs0000644000000000000000000003672613623162342017007 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Signature -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Signature ( createCertificateVerify , checkCertificateVerify , digitallySignDHParams , digitallySignECDHParams , digitallySignDHParamsVerify , digitallySignECDHParamsVerify , checkSupportedHashSignature , certificateCompatible , signatureCompatible , signatureCompatible13 , hashSigToCertType , signatureParams , decryptError ) where import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Packet (generateCertificateVerify_SSL, generateCertificateVerify_SSL_DSS, encodeSignedDHParams, encodeSignedECDHParams) import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Key import Network.TLS.Util import Network.TLS.X509 import Control.Monad.State.Strict decryptError :: MonadIO m => String -> m a decryptError msg = throwCore $ Error_Protocol (msg, True, DecryptError) -- | Check that the key is compatible with a list of 'CertificateType' values. -- Ed25519 and Ed448 have no assigned code point and are checked with extension -- "signature_algorithms" only. certificateCompatible :: PubKey -> [CertificateType] -> Bool certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes certificateCompatible (PubKeyDSA _) cTypes = CertificateType_DSS_Sign `elem` cTypes certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes certificateCompatible (PubKeyEd25519 _) _ = True certificateCompatible (PubKeyEd448 _) _ = True certificateCompatible _ _ = False signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1 signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512 signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256 signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384 signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512 signatureCompatible (PubKeyDSA _) (_, SignatureDSS) = True signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True signatureCompatible _ (_, _) = False -- 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 (_, SignatureDSS) = Just CertificateType_DSS_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 _) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> return False (TLS12, Just hs) | pubKey `signatureCompatible` hs -> doVerify | otherwise -> return False (_, Nothing) -> doVerify (_, Just _) -> return False where doVerify = prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>= signatureVerifyWithCertVerifyData ctx digSig createCertificateVerify :: Context -> Version -> PubKey -> Maybe 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 -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> ByteString -> IO CertVerifyData prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs | usedVersion == SSL3 = do (hashCtx, params, generateCV_SSL) <- case pubKey of PubKeyRSA _ -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL) PubKeyDSA _ -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS) _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ pubkeyType pubKey) Just masterSecret <- usingHState ctx $ gets hstMasterSecret return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs) | usedVersion == TLS10 || usedVersion == TLS11 = return $ buildVerifyData (signatureParams pubKey Nothing) msgs | otherwise = return (signatureParams pubKey hashSigAlg, msgs) signatureParams :: PubKey -> Maybe HashAndSignatureAlgorithm -> SignatureParams signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 Just (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 Just (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 Just (HashSHA1 , SignatureRSA) -> RSAParams SHA1 RSApkcs1 Just (HashIntrinsic , SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss Just (HashIntrinsic , SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss Just (HashIntrinsic , SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss Nothing -> RSAParams SHA1_MD5 RSApkcs1 Just (hsh , SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of Nothing -> DSSParams Just (HashSHA1, SignatureDSS) -> DSSParams Just (_ , SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed" Just (_ , sigAlg) -> error ("signature algorithm is incompatible with DSS: " ++ show sigAlg) signatureParams (PubKeyEC _) hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 Just (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 Just (HashSHA1 , SignatureECDSA) -> ECDSAParams SHA1 Nothing -> ECDSAParams SHA1 Just (hsh , SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) signatureParams (PubKeyEd25519 _) hashSigAlg = case hashSigAlg of Nothing -> Ed25519Params Just (HashIntrinsic , SignatureEd25519) -> Ed25519Params Just (hsh , SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) signatureParams (PubKeyEd448 _) hashSigAlg = case hashSigAlg of Nothing -> Ed448Params Just (HashIntrinsic , SignatureEd448) -> Ed448Params Just (hsh , SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") signatureCreateWithCertVerifyData :: Context -> Maybe HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do cc <- usingState_ ctx isClientContext DigitallySigned malg <$> signPrivate ctx cc sigParam toSign signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = do usedVersion <- usingState_ ctx getVersion let (sigParam, toVerify) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" (TLS12, Just hs) | pubKey `signatureCompatible` hs -> (signatureParams pubKey hashSigAlg, toVerifyData) | otherwise -> error "expecting different signature algorithm" (_, Nothing) -> buildVerifyData (signatureParams pubKey Nothing) toVerifyData (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" 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 -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned digitallySignParams ctx signatureData pubKey hashSigAlg = let sigParam = signatureParams pubKey hashSigAlg in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData) digitallySignDHParams :: Context -> ServerDHParams -> PubKey -> Maybe 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 -> Maybe 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 "withClientAndServer : server random" <$> gets hstServerRandom) return $ f cran sran -- verify that the hash and signature selected by the peer is supported in -- the local configuration checkSupportedHashSignature :: Context -> Maybe HashAndSignatureAlgorithm -> IO () checkSupportedHashSignature _ Nothing = return () checkSupportedHashSignature ctx (Just hs) = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ let msg = "unsupported hash and signature algorithm: " ++ show hs in throwCore $ Error_Protocol (msg, True, IllegalParameter) tls-1.5.4/Network/TLS/Handshake/Certificate.hs0000644000000000000000000000450313623162342017254 0ustar0000000000000000-- | -- Module : Network.TLS.Handshake.Certificate -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Certificate ( certificateRejected , badCertificate , rejectOnException , verifyLeafKeyUsage , extractCAname ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509 import Control.Monad.State.Strict import Control.Exception (SomeException) import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet) -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a certificateRejected CertificateRejectRevoked = throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked) certificateRejected CertificateRejectExpired = throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired) certificateRejected CertificateRejectUnknownCA = throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa) certificateRejected CertificateRejectAbsent = throwCore $ Error_Protocol ("certificate is missing", True, CertificateRequired) certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) badCertificate :: MonadIO m => String -> m a badCertificate msg = throwCore $ Error_Protocol (msg, True, 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-1.5.4/Network/TLS/Handshake/State13.hs0000644000000000000000000001155513623162342016263 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.State13 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.State13 ( getTxState , getRxState , setTxState , setRxState , clearTxState , clearRxState , setHelloParameters13 , transcriptHash , wrapAsMessageHash13 , PendingAction(..) , setPendingActions , popPendingAction ) 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.KeySchedule (hkdfExpandLabel) import Network.TLS.Record.State import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Util getTxState :: Context -> IO (Hash, Cipher, ByteString) getTxState ctx = getXState ctx ctxTxState getRxState :: Context -> IO (Hash, Cipher, ByteString) getRxState ctx = getXState ctx ctxRxState getXState :: Context -> (Context -> MVar RecordState) -> IO (Hash, Cipher, ByteString) getXState ctx func = do tx <- readMVar (func ctx) let Just usedCipher = stCipher tx usedHash = cipherHash usedCipher secret = cstMacSecret $ stCryptState tx return (usedHash, usedCipher, secret) setTxState :: Context -> Hash -> Cipher -> ByteString -> IO () setTxState = setXState ctxTxState BulkEncrypt setRxState :: Context -> Hash -> Cipher -> ByteString -> IO () setRxState = setXState ctxRxState BulkDecrypt setXState :: (Context -> MVar RecordState) -> BulkDirection -> Context -> Hash -> Cipher -> ByteString -> IO () setXState func encOrDec ctx h cipher 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 } , stCipher = Just cipher , stCompression = nullCompression } clearTxState :: Context -> IO () clearTxState = clearXState ctxTxState clearRxState :: Context -> IO () clearRxState = clearXState ctxRxState clearXState :: (Context -> MVar RecordState) -> Context -> IO () clearXState func ctx = modifyMVar_ (func ctx) (\rt -> return rt { stCipher = Nothing }) setHelloParameters13 :: Cipher -> HandshakeM (Either TLSError ()) setHelloParameters13 cipher = do hst <- get case hstPendingCipher hst of Nothing -> do put hst { hstPendingCipher = Just cipher , hstPendingCompression = nullCompression , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst } return $ Right () Just oldcipher | cipher == oldcipher -> return $ Right () | otherwise -> return $ Left $ Error_Protocol ("TLS 1.3 cipher changed after hello retry", True, IllegalParameter) where hashAlg = cipherHash cipher updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest" -- When a HelloRetryRequest is sent or received, the existing transcript must be -- wrapped in a "message_hash" construct. See RFC 8446 section 4.4.1. This -- applies to key-schedule computations as well as the ones for PSK binders. wrapAsMessageHash13 :: HandshakeM () wrapAsMessageHash13 = do cipher <- getPendingCipher foldHandshakeDigest (cipherHash cipher) foldFunc where foldFunc dig = B.concat [ "\254\0\0" , B.singleton (fromIntegral $ B.length dig) , dig ] transcriptHash :: MonadIO m => Context -> m ByteString transcriptHash ctx = do hst <- fromJust "HState" <$> getHState ctx case hstHandshakeDigest hst of HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx HandshakeMessages _ -> error "un-initialized handshake digest" setPendingActions :: Context -> [PendingAction] -> IO () setPendingActions ctx = writeIORef (ctxPendingActions ctx) popPendingAction :: Context -> IO (Maybe PendingAction) popPendingAction ctx = do let ref = ctxPendingActions ctx actions <- readIORef ref case actions of bs:bss -> writeIORef ref bss >> return (Just bs) [] -> return Nothing tls-1.5.4/Network/TLS/Handshake/Server.hs0000644000000000000000000016732613623162342016315 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Server ( handshakeServer , handshakeServerWith , requestCertificateServer , postHandshakeAuthServerWith ) where import Network.TLS.Parameters import Network.TLS.Imports import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Util (bytesEq, catchException, fromJust) import Network.TLS.IO import Network.TLS.Types import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random import Network.TLS.Measurement import qualified Data.ByteString as B import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict import Control.Exception (bracket) import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Common import Network.TLS.Handshake.Certificate import Network.TLS.X509 import Network.TLS.Handshake.State13 import Network.TLS.Handshake.Common13 -- Put the server context in handshake mode. -- -- Expect to receive as first packet a client hello handshake message -- -- This is just a helper to pop the next message from the recv layer, -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do hss <- recvPacketHandshake ctx case hss of [ch] -> handshakeServerWith sparams ctx ch _ -> unexpected (show hss) (Just "client hello") -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter. -- This is useful when the client hello has been already poped from the recv layer to inspect the packet. -- -- When the function returns, a new handshake has been succesfully negociated. -- On any error, a HandshakeFailed exception is raised. -- -- handshake protocol (<- receiving, -> sending, [] optional): -- (no session) (session resumption) -- <- client hello <- client hello -- -> server hello -> server hello -- -> [certificate] -- -> [server key xchg] -- -> [cert request] -- -> hello done -- <- [certificate] -- <- client key xchg -- <- [cert verify] -- <- change cipher -> change cipher -- <- finish -> finish -- -> change cipher <- change cipher -- -> finish <- finish -- handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () handshakeServerWith sparams ctx clientHello@(ClientHello legacyVersion _ clientSession ciphers compressions exts _) = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do ver <- usingState_ ctx (getVersionWithDefault TLS10) when (ver == TLS13) $ throwCore $ Error_Protocol ("renegotiation is not allowed in TLS 1.3", True, UnexpectedMessage) -- rejecting client initiated renegotiation to prevent DOS. eof <- ctxEOF ctx let renegotiation = established == Established && not eof when (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $ throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation) -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes -- Handle Client hello processHandshake ctx clientHello -- rejecting SSL2. RFC 6176 when (legacyVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion) -- rejecting SSL3. RFC 7568 -- when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion) -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) && (0x5600 `elem` ciphers) && legacyVersion < TLS12) $ throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback) -- choosing TLS version let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of Just (SupportedVersionsClientHello vers) -> vers _ -> [] clientVersion = min TLS12 legacyVersion serverVersions | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) | otherwise = supportedVersions $ ctxSupported ctx mVersion = debugVersionForced $ serverDebug sparams chosenVersion <- case mVersion of Just cver -> return cver Nothing -> if (TLS13 `elem` serverVersions) && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion) Just v -> return v else case findHighestVersionFrom clientVersion serverVersions of Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion) Just v -> return v -- SNI (Server Name Indication) let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode MsgTClientHello of Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) where toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing _ -> Nothing maybe (return ()) (usingState_ ctx . setClientSNI) serverName -- ALPN (Application Layer Protocol Negotiation) case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos _ -> return () -- TLS version dependent if chosenVersion <= TLS12 then handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession else do mapM_ ensureNullCompression compressions -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry. handshakeServerWithTLS13 sparams ctx chosenVersion exts ciphers serverName clientSession handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) -- TLS 1.2 or earlier handshakeServerWithTLS12 :: ServerParams -> Context -> Version -> [ExtensionRaw] -> [CipherID] -> Maybe String -> Version -> [CompressionID] -> Session -> IO () handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession = do extraCreds <- onServerNameIndication (serverHooks sparams) serverName let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) -- If compression is null, commonCompressions should be [0]. when (null commonCompressions) $ throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) -- When selecting a cipher we must ensure that it is allowed for the -- TLS version but also that all its key-exchange requirements -- will be met. -- Some ciphers require a signature and a hash. With TLS 1.2 the hash -- algorithm is selected from a combination of server configuration and -- the client "supported_signatures" extension. So we cannot pick -- such a cipher if no hash is available for it. It's best to skip this -- cipher and pick another one (with another key exchange). -- Cipher selection is performed in two steps: first server credentials -- are flagged as not suitable for signature if not compatible with -- negotiated signature parameters. Then ciphers are evalutated from -- the resulting credentials. let possibleGroups = negotiatedGroupsInCommon ctx exts possibleECGroups = possibleGroups `intersect` availableECGroups possibleFFGroups = possibleGroups `intersect` availableFFGroups hasCommonGroupForECDHE = not (null possibleECGroups) hasCommonGroupForFFDHE = not (null possibleFFGroups) hasCustomGroupForFFDHE = isJust (serverDHEParams sparams) canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE hasCommonGroup cipher = case cipherKeyExchange cipher of CipherKeyExchange_DH_Anon -> canFFDHE CipherKeyExchange_DHE_RSA -> canFFDHE CipherKeyExchange_DHE_DSS -> canFFDHE CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE _ -> True -- group not used -- Ciphers are selected according to TLS version, availability of -- (EC)DHE group and credential depending on key exchange. cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) (creds, signatureCreds, ciphersFilteredVersion) = case chosenVersion of TLS12 -> let -- Build a list of all hash/signature algorithms in common between -- client and server. possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts -- Check that a candidate signature credential will be compatible with -- client & server hash/signature algorithms. This returns Just Int -- in order to sort credentials according to server hash/signature -- preference. When the certificate has no matching hash/signature in -- 'possibleHashSigAlgs' the result is Nothing, and the credential will -- not be used to sign. This avoids a failure later in 'decideHashSig'. signingRank cred = case credentialDigitalSignatureKey cred of Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs Nothing -> Nothing -- Finally compute credential lists and resulting cipher list. -- -- We try to keep certificates supported by the client, but -- fallback to all credentials if this produces no suitable result -- (see RFC 5246 section 7.4.2 and RFC 8446 section 4.4.2.2). -- The condition is based on resulting (EC)DHE ciphers so that -- filtering credentials does not give advantage to a less secure -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon. cltCreds = filterCredentialsWithHashSignatures exts allCreds sigCltCreds = filterSortCredentials signingRank cltCreds sigAllCreds = filterSortCredentials signingRank allCreds cltCiphers = selectCipher cltCreds sigCltCreds allCiphers = selectCipher allCreds sigAllCreds resultTuple = if cipherListCredentialFallback cltCiphers then (allCreds, sigAllCreds, allCiphers) else (cltCreds, sigCltCreds, cltCiphers) in resultTuple _ -> let sigAllCreds = filterCredentials (isJust . credentialDigitalSignatureKey) allCreds allCiphers = selectCipher allCreds sigAllCreds in (allCreds, sigAllCreds, allCiphers) -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds CipherKeyExchange_DH_Anon -> return Nothing CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning KX_DSS signatureCreds CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) ems <- processExtendedMasterSec ctx chosenVersion MsgTClientHello exts resumeSessionData <- case clientSession of (Session (Just clientSessionId)) -> do let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId resume >>= validateSession serverName ems (Session Nothing) -> return Nothing -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed. case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode MsgTClientHello of Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs _ -> return () doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts where commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds) commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions usedCompression = head commonCompressions validateSession _ _ Nothing = return Nothing validateSession sni ems m@(Just sd) -- SessionData parameters are assumed to match the local server configuration -- so we need to compare only to ClientHello inputs. Abbreviated handshake -- uses the same server_name than full handshake so the same -- credentials (and thus ciphers) are available. | clientVersion < sessionVersion sd = return Nothing | sessionCipher sd `notElem` ciphers = return Nothing | sessionCompression sd `notElem` compressions = return Nothing | isJust sni && sessionClientSNI sd /= sni = return Nothing | ems && not emsSession = return Nothing | not ems && emsSession = let err = "client resumes an EMS session without EMS" in throwCore $ Error_Protocol (err, True, HandshakeFailure) | otherwise = return m where emsSession = SessionEMS `elem` sessionFlags sd doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher -> Compression -> Session -> Maybe SessionData -> [ExtensionRaw] -> IO () doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do case resumeSessionData of Nothing -> do handshakeSendServerData liftIO $ contextFlush ctx -- Receive client info until client Finished. recvClientData sparams ctx sendChangeCipherAndFinish ctx ServerRole Just sessionData -> do usingState_ ctx (setSession clientSession True) serverhello <- makeServerHello clientSession sendPacket ctx $ Handshake [serverhello] let masterSecret = sessionSecret sessionData usingHState ctx $ setMasterSecret chosenVersion ServerRole masterSecret logKey ctx (MasterSecret masterSecret) sendChangeCipherAndFinish ctx ServerRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where --- -- When the client sends a certificate, check whether -- it is acceptable for the application. -- --- makeServerHello session = do srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams case mcred of Just cred -> storePrivInfoServer ctx cred _ -> return () -- return a sensible error -- in TLS12, we need to check as well the certificates we are sending if they have in the extension -- the necessary bits set. secReneg <- usingState_ ctx getSecureRenegotiation secRengExt <- if secReneg then do vf <- usingState_ ctx $ do cvf <- getVerifiedData ClientRole svf <- getVerifiedData ServerRole return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ ExtensionRaw extensionID_SecureRenegotiation vf ] else return [] ems <- usingHState ctx getExtendedMasterSec let emsExt | ems = let raw = extensionEncode ExtendedMasterSecret in [ ExtensionRaw extensionID_ExtendedMasterSecret raw ] | otherwise = [] protoExt <- applicationProtocol ctx exts sparams sniExt <- do resuming <- usingState_ ctx isSessionResuming if resuming then return [] else do msni <- usingState_ ctx getClientSNI case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty. Just _ -> return [ ExtensionRaw extensionID_ServerName ""] Nothing -> return [] let extensions = secRengExt ++ emsExt ++ protoExt ++ sniExt usingState_ ctx (setVersion chosenVersion) usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression return $ ServerHello chosenVersion srand session (cipherID usedCipher) (compressionID usedCompression) extensions handshakeSendServerData = do serverSession <- newSession ctx usingState_ ctx (setSession serverSession False) serverhello <- makeServerHello serverSession -- send ServerHello & Certificate & ServerKeyXchg & CertReq let certMsg = case mcred of Just (srvCerts, _) -> Certificates srvCerts _ -> Certificates $ CertificateChain [] sendPacket ctx $ Handshake [ serverhello, certMsg ] -- send server key exchange if needed skx <- case cipherKeyExchange usedCipher of CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE KX_DSS CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA _ -> return Nothing maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx -- FIXME we don't do this on a Anonymous server -- When configured, send a certificate request with the DNs of all -- configured CA certificates. -- -- Client certificates MUST NOT be accepted if not requested. -- when (serverWantClientCert sparams) $ do usedVersion <- usingState_ ctx getVersion let defaultCertTypes = [ CertificateType_RSA_Sign , CertificateType_DSS_Sign , CertificateType_ECDSA_Sign ] (certTypes, hashSigs) | usedVersion < TLS12 = (defaultCertTypes, Nothing) | otherwise = let as = supportedHashSignatures $ ctxSupported ctx in (nub $ mapMaybe hashSigToCertType as, Just as) creq = CertRequest certTypes hashSigs (map extractCAname $ serverCACertificates sparams) usingHState ctx $ setCertReqSent True sendPacket ctx (Handshake [creq]) -- Send HelloDone sendPacket ctx (Handshake [ServerHelloDone]) setup_DHE = do let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups (dhparams, priv, pub) <- case possibleFFGroups of [] -> let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams in case findFiniteFieldGroup dhparams of Just g -> do usingHState ctx $ setNegotiatedGroup g generateFFDHE ctx g Nothing -> do (priv, pub) <- generateDHE ctx dhparams return (dhparams, priv, pub) g:_ -> do usingHState ctx $ setNegotiatedGroup g generateFFDHE ctx g let serverParams = serverDHParamsFrom dhparams pub usingHState ctx $ setServerDHParams serverParams usingHState ctx $ setDHPrivate priv return serverParams -- Choosing a hash algorithm to sign (EC)DHE parameters -- in ServerKeyExchange. Hash algorithm is not suggested by -- the chosen cipher suite. So, it should be selected based on -- the "signature_algorithms" extension in a client hello. -- If RSA is also used for key exchange, this function is -- not called. decideHashSig pubKey = do usedVersion <- usingState_ ctx getVersion case usedVersion of TLS12 -> do let hashSigs = hashAndSignaturesInCommon ctx exts case filter (pubKey `signatureCompatible`) hashSigs of [] -> error ("no hash signature for " ++ pubkeyType pubKey) x:_ -> return $ Just x _ -> return Nothing generateSKX_DHE kxsAlg = do serverParams <- setup_DHE pubKey <- getLocalPublicKey ctx mhashSig <- decideHashSig pubKey signed <- digitallySignDHParams ctx serverParams pubKey mhashSig case kxsAlg of KX_RSA -> return $ SKX_DHE_RSA serverParams signed KX_DSS -> return $ SKX_DHE_DSS serverParams signed _ -> error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg) generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE setup_ECDHE grp = do usingHState ctx $ setNegotiatedGroup grp (srvpri, srvpub) <- generateECDHE ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams usingHState ctx $ setGroupPrivate srvpri return serverParams generateSKX_ECDHE kxsAlg = do let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) g:_ -> return g serverParams <- setup_ECDHE grp pubKey <- getLocalPublicKey ctx mhashSig <- decideHashSig pubKey signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig case kxsAlg of KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed _ -> error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg) -- create a DigitallySigned objects for DHParams or ECDHParams. -- | receive Client data in handshake until the Finished handshake. -- -- <- [certificate] -- <- client key xchg -- <- [cert verify] -- <- change cipher -- <- finish -- recvClientData :: ServerParams -> Context -> IO () recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) where processClientCertificate (Certificates certs) = do clientCertificate sparams ctx certs -- FIXME: We should check whether the certificate -- matches our request and that we support -- verifying with that certificate. return $ RecvStateHandshake processClientKeyExchange processClientCertificate p = processClientKeyExchange p -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher, -- so we must process any packet, and in case of handshake call processHandshake manually. processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify processClientKeyExchange p = unexpected (show p) (Just "client key exchange") -- Check whether the client correctly signed the handshake. -- If not, ask the application on how to proceed. -- processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do processHandshake ctx hs certs <- checkValidClientCertChain ctx "change cipher message expected" usedVersion <- usingState_ ctx getVersion -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages pubKey <- usingHState ctx getRemotePublicKey checkDigitalSignatureKey usedVersion pubKey verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig clientCertVerify sparams ctx certs verif return $ RecvStateNext expectChangeCipher processCertificateVerify p = do chain <- usingHState ctx getClientCertChain case chain of Just cc | isNullCertificateChain cc -> return () | otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage) Nothing -> return () expectChangeCipher p expectChangeCipher ChangeCipherSpec = do return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain checkValidClientCertChain ctx errmsg = do chain <- usingHState ctx getClientCertChain let throwerror = Error_Protocol (errmsg , True, UnexpectedMessage) case chain of Nothing -> throwCore throwerror Just cc | isNullCertificateChain cc -> throwCore throwerror | otherwise -> return cc hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] hashAndSignaturesInCommon ctx exts = let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of -- See Section 7.4.1.4.1 of RFC 5246. Nothing -> [(HashSHA1, SignatureECDSA) ,(HashSHA1, SignatureRSA) ,(HashSHA1, SignatureDSS)] Just (SignatureAlgorithms sas) -> sas sHashSigs = supportedHashSignatures $ ctxSupported ctx -- The values in the "signature_algorithms" extension -- are in descending order of preference. -- However here the algorithms are selected according -- to server preference in 'supportedHashSignatures'. in sHashSigs `intersect` cHashSigs negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of Just (NegotiatedGroups clientGroups) -> let serverGroups = supportedGroups (ctxSupported ctx) in serverGroups `intersect` clientGroups _ -> [] credentialDigitalSignatureKey :: Credential -> Maybe PubKey credentialDigitalSignatureKey cred | isDigitalSignaturePair keys = Just pubkey | otherwise = Nothing where keys@(pubkey, _) = credentialPublicPrivateKeys cred filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials filterCredentials p (Credentials l) = Credentials (filter p l) filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials filterSortCredentials rankFun (Credentials creds) = let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ] in Credentials [ cred | (Just _, cred) <- orderedPairs ] isCredentialAllowed :: Version -> Credential -> Bool isCredentialAllowed ver cred = pubkey `versionCompatible` ver 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 = case withExt extensionID_SignatureAlgorithmsCert of Just (SignatureAlgorithmsCert sas) -> withAlgs sas Nothing -> case withExt extensionID_SignatureAlgorithms of Nothing -> id Just (SignatureAlgorithms sas) -> withAlgs sas where withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) -- returns True if certificate filtering with "signature_algorithms_cert" / -- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so -- handshake with lower security) cipherListCredentialFallback :: [Cipher] -> Bool cipherListCredentialFallback = all nonDH where nonDH x = case cipherKeyExchange x of CipherKeyExchange_DHE_RSA -> False CipherKeyExchange_DHE_DSS -> False CipherKeyExchange_ECDHE_RSA -> False CipherKeyExchange_ECDHE_ECDSA -> False CipherKeyExchange_TLS13 -> False _ -> True storePrivInfoServer :: MonadIO m => Context -> Credential -> m () storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey) -- TLS 1.3 or later handshakeServerWithTLS13 :: ServerParams -> Context -> Version -> [ExtensionRaw] -> [CipherID] -> Maybe String -> Session -> IO () handshakeServerWithTLS13 sparams ctx chosenVersion exts clientCiphers _serverName clientSession = do when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $ throwCore $ Error_Protocol ("extension pre_shared_key must be last", True, IllegalParameter) -- Deciding cipher. -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion usedHash = cipherHash usedCipher rtt0 = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTClientHello of Just (EarlyDataIndication _) -> True Nothing -> False when rtt0 $ -- mark a 0-RTT attempt before a possible HRR, and before updating the -- status again if 0-RTT successful setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding -- Deciding key exchange from key shares keyShares <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTClientHello of Just (KeyShareClientHello kses) -> return kses Just _ -> error "handshakeServerWithTLS13: invalid KeyShare value" _ -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) case findKeyShare keyShares serverGroups of Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession Just keyShare -> doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash keyShare clientSession rtt0 where ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams) serverGroups = supportedGroups (ctxSupported ctx) findKeyShare _ [] = Nothing findKeyShare ks (g:gs) = case find (\ent -> keyShareEntryGroup ent == g) ks of Just k -> Just k Nothing -> findKeyShare ks gs doHandshake13 :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> Hash -> KeyShareEntry -> Session -> Bool -> IO () doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do newSession ctx >>= \ss -> usingState_ ctx $ do setSession ss False setClientSupportsPHA supportsPHA usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter -- ALPN is used in choosePSK protoExt <- applicationProtocol ctx exts sparams (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) True let earlySecret = pairBase earlyKey ClientTrafficSecret clientEarlySecret = pairClient earlyKey extensions <- checkBinder earlySecret binderInfo hrr <- usingState_ ctx getTLS13HRR let authenticated = isJust binderInfo rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) let allCreds = filterCredentials (isCredentialAllowed chosenVersion) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) ---------------------------------------------------------------- established <- ctxEstablished ctx if established /= NotEstablished then if rtt0OK then do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted else do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Rejected else if authenticated then usingHState ctx $ setTLS13HandshakeMode PreSharedKey else -- FullHandshake or HelloRetryRequest return () mCredInfo <- if authenticated then return Nothing else decideCredentialInfo allCreds (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx (clientHandshakeSecret, handshakeSecret) <- runPacketFlight ctx $ do sendServerHello keyShare srand extensions sendChangeCipherSpec13 ctx ---------------------------------------------------------------- handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe let ServerTrafficSecret serverHandshakeSecret = triServer handKey ClientTrafficSecret clientHandshakeSecret = triClient handKey liftIO $ do setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlySecret else clientHandshakeSecret setTxState ctx usedHash usedCipher serverHandshakeSecret ---------------------------------------------------------------- sendExtensions rtt0OK protoExt case mCredInfo of Nothing -> return () Just (cred, hashSig) -> sendCertAndVerify cred hashSig rawFinished <- makeFinished ctx usedHash serverHandshakeSecret loadPacket13 ctx $ Handshake13 [rawFinished] return (clientHandshakeSecret, triBase handKey) sfSentTime <- getCurrentTimeFromBase ---------------------------------------------------------------- hChSf <- transcriptHash ctx appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf let ClientTrafficSecret clientApplicationSecret0 = triClient appKey ServerTrafficSecret serverApplicationSecret0 = triServer appKey applicationSecret = triBase appKey setTxState ctx usedHash usedCipher serverApplicationSecret0 ---------------------------------------------------------------- if rtt0OK then setEstablished ctx (EarlyDataAllowed rtt0max) else when (established == NotEstablished) $ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do checkFinished usedHash clientHandshakeSecret hChBeforeCf verifyData handshakeTerminate13 ctx setRxState ctx usedHash usedCipher clientApplicationSecret0 sendNewSessionTicket applicationSecret sfSentTime expectFinished _ hs = unexpected (show hs) (Just "finished 13") let expectEndOfEarlyData EndOfEarlyData13 = setRxState ctx usedHash usedCipher clientHandshakeSecret expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data") if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do skip <- recvHandshake13 ctx expectCertificate unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx) recvHandshake13hash ctx expectFinished ensureRecvComplete ctx else if rtt0OK then setPendingActions ctx [PendingAction True expectEndOfEarlyData ,PendingActionHash True expectFinished] else runRecvHandshake13 $ do recvHandshake13hash ctx expectFinished ensureRecvComplete ctx where choice = makeCipherChoice chosenVersion usedCipher setServerParameter = do srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion chosenVersion failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher return srand supportsPHA = case extensionLookup extensionID_PostHandshakeAuth exts >>= extensionDecode MsgTClientHello of Just PostHandshakeAuth -> True Nothing -> False choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> do when (null dhModes) $ throwCore $ Error_Protocol ("no psk_key_exchange_modes extension", True, MissingExtension) if PSK_DHE_KE `elem` dhModes then do let len = sum (map (\x -> B.length x + 1) bnds) + 2 mgr = sharedSessionManager $ serverShared sparams msdata <- if rtt0 then sessionResumeOnlyOnce mgr sessionId else sessionResume mgr sessionId case msdata of Just sdata -> do let Just tinfo = sessionTicketInfo sdata psk = sessionSecret sdata isFresh <- checkFreshness tinfo obfAge (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata if isPSKvalid && isFresh then return (psk, Just (bnd,0::Int,len),is0RTTvalid) else -- fall back to full handshake return (zero, Nothing, False) _ -> return (zero, Nothing, False) else return (zero, Nothing, False) _ -> return (zero, Nothing, False) checkSessionEquality sdata = do msni <- usingState_ ctx getClientSNI malpn <- usingState_ ctx getNegotiatedProtocol let isSameSNI = sessionClientSNI sdata == msni isSameCipher = sessionCipher sdata == cipherID usedCipher ciphers = supportedCiphers $ serverSupported sparams isSameKDF = case find (\c -> cipherID c == sessionCipher sdata) ciphers of Nothing -> False Just c -> cipherHash c == cipherHash usedCipher isSameVersion = chosenVersion == sessionVersion sdata isSameALPN = sessionALPN sdata == malpn isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required is0RTTvalid = isSameVersion && isSameCipher && isSameALPN return (isPSKvalid, is0RTTvalid) rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams rtt0accept = serverEarlyDataSize sparams > 0 checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder,n,tlen)) = do binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing unless (binder `bytesEq` binder') $ decryptError "PSK binder validation failed" let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n return [ExtensionRaw extensionID_PreSharedKey selectedIdentity] decideCredentialInfo allCreds = do cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension) Just (SignatureAlgorithms sas) -> return sas -- When deciding signature algorithm and certificate, we try to keep -- certificates supported by the client, but fallback to all credentials -- if this produces no suitable result (see RFC 5246 section 7.4.2 and -- RFC 8446 section 4.4.2.2). let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx hashSigs = sHashSigs `intersect` cHashSigs cltCreds = filterCredentialsWithHashSignatures exts allCreds case credentialsFindForSigning13 hashSigs cltCreds of Nothing -> case credentialsFindForSigning13 hashSigs allCreds of Nothing -> throwCore $ Error_Protocol ("credential not found", True, HandshakeFailure) mcs -> return mcs mcs -> return mcs sendServerHello keyShare srand extensions = do let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare : ExtensionRaw extensionID_SupportedVersions selectedVersion : extensions helo = ServerHello13 srand clientSession (cipherID usedCipher) extensions' loadPacket13 ctx $ Handshake13 [helo] sendCertAndVerify cred@(certChain, _) hashSig = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here. certReq = makeCertRequest sparams ctx certReqCtx loadPacket13 ctx $ Handshake13 [certReq] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) [] loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess] hChSc <- transcriptHash ctx pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc loadPacket13 ctx $ Handshake13 [vrfy] sendExtensions rtt0OK protoExt = do msni <- liftIO $ usingState_ ctx getClientSNI let sniExtension = case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty. Just _ -> Just $ ExtensionRaw extensionID_ServerName "" Nothing -> Nothing mgroup <- usingHState ctx getNegotiatedGroup let serverGroups = supportedGroups (ctxSupported ctx) groupExtension | null serverGroups = Nothing | maybe True (== head serverGroups) mgroup = Nothing | otherwise = Just $ ExtensionRaw extensionID_NegotiatedGroups $ extensionEncode (NegotiatedGroups serverGroups) let earlyDataExtension | rtt0OK = Just $ ExtensionRaw extensionID_EarlyData $ extensionEncode (EarlyDataIndication Nothing) | otherwise = Nothing let extensions = catMaybes [earlyDataExtension, groupExtension, sniExtension] ++ protoExt loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions] sendNewSessionTicket applicationSecret sfSentTime = when sendNST $ do cfRecvTime <- getCurrentTimeFromBase let rtt = cfRecvTime - sfSentTime nonce <- getStateRNG ctx 32 resumptionMasterSecret <- calculateResumptionSecret ctx choice applicationSecret let life = toSeconds $ serverTicketLifetime sparams psk = derivePSK choice resumptionMasterSecret nonce (label, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce label rtt0max sendPacket13 ctx $ Handshake13 [nst] where sendNST = PSK_DHE_KE `elem` dhModes generateSession life psk maxSize rtt = do Session (Just sessionId) <- newSession ctx tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt) sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk let mgr = sharedSessionManager $ serverShared sparams sessionEstablish mgr sessionId sdata return (sessionId, ageAdd tinfo) createNewSessionTicket life add nonce label maxSize = NewSessionTicket13 life add nonce label extensions where tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize extensions = [ExtensionRaw extensionID_EarlyData tedi] toSeconds i | i < 0 = 0 | i > 604800 = 604800 | otherwise = fromIntegral i dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of Just (PskKeyExchangeModes ms) -> ms Nothing -> [] expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol ("certificate request context MUST be empty", True, IllegalParameter) -- fixme checking _ext clientCertificate sparams ctx certs return $ isNullCertificateChain certs expectCertificate hs = unexpected (show hs) (Just "certificate 13") hashSize = hashDigestSize usedHash zero = B.replicate hashSize 0 expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected" pubkey <- case cc of [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure) c:_ -> return $ certPubKey $ getCertificate c ver <- usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey verif <- checkCertVerify ctx pubkey sigAlg sig hChCc clientCertVerify sparams ctx certs verif expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> m () helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = liftIO $ do twice <- usingState_ ctx getTLS13HRR when twice $ throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure) usingState_ ctx $ setTLS13HRR True failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of Just (NegotiatedGroups gs) -> gs Nothing -> [] possibleGroups = serverGroups `intersect` clientGroups case possibleGroups of [] -> throwCore $ Error_Protocol ("no group in common with the client for HRR", True, HandshakeFailure) g:_ -> do let serverKeyShare = extensionEncode $ KeyShareHRR g selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion extensions = [ExtensionRaw extensionID_KeyShare serverKeyShare ,ExtensionRaw extensionID_SupportedVersions selectedVersion] hrr = ServerHello13 hrrRandom clientSession (cipherID usedCipher) extensions usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest runPacketFlight ctx $ do loadPacket13 ctx $ Handshake13 [hrr] sendChangeCipherSpec13 ctx handshakeServer sparams ctx findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of [] -> Nothing v:_ -> Just v -- We filter our allowed ciphers here according to dynamic credential lists. -- Credentials 'creds' come from server parameters but also SNI callback. -- When the key exchange requires a signature, we use a -- subset of this list named 'sigCreds'. This list has been filtered in order -- to remove certificates that are not compatible with hash/signature -- restrictions (TLS 1.2). getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher] getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams) where authorizedCKE cipher = case cipherKeyExchange cipher of CipherKeyExchange_RSA -> canEncryptRSA CipherKeyExchange_DH_Anon -> True CipherKeyExchange_DHE_RSA -> canSignRSA CipherKeyExchange_DHE_DSS -> canSignDSS CipherKeyExchange_ECDHE_RSA -> canSignRSA CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA -- unimplemented: non ephemeral DH & ECDH. -- Note, these *should not* be implemented, and have -- (for example) been removed in OpenSSL 1.1.0 -- CipherKeyExchange_DH_DSS -> False CipherKeyExchange_DH_RSA -> False CipherKeyExchange_ECDH_ECDSA -> False CipherKeyExchange_ECDH_RSA -> False CipherKeyExchange_TLS13 -> False -- not reached canSignDSS = KX_DSS `elem` signingAlgs canSignRSA = KX_RSA `elem` signingAlgs canSignECDSA = KX_ECDSA `elem` signingAlgs canEncryptRSA = isJust $ credentialsFindForDecrypting creds signingAlgs = credentialsListSigningAlgorithms sigCreds findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of [] -> Nothing v:_ -> Just v where svs = sortOn Down serverVersions cvs = sortOn Down clientVersions applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] applicationProtocol ctx exts sparams | clientALPNSuggest = do suggest <- usingState_ ctx getClientALPNSuggest case (onALPNClientSuggest $ serverHooks sparams, suggest) of (Just io, Just protos) -> do proto <- io protos usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] (_, _) -> return [] | otherwise = return [] where clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm) credentialsFindForSigning13 hss0 creds = loop hss0 where loop [] = Nothing loop (hs:hss) = case credentialsFindForSigning13' hs creds of Nothing -> credentialsFindForSigning13 hss creds Just cred -> Just (cred, hs) -- See credentialsFindForSigning. credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l where forSigning cred = case credentialDigitalSignatureKey cred of Nothing -> False Just pub -> pub `signatureCompatible13` sigAlg clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- Call application callback to see whether the -- certificate chain is acceptable. -- usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException case usage of CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs CertificateUsageReject reason -> certificateRejected reason -- Remember cert chain for later use. -- usingHState ctx $ setClientCertChain certs clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO () clientCertVerify sparams ctx certs verif = do if verif then do -- When verification succeeds, commit the -- client certificate chain to the context. -- usingState_ ctx $ setClientCertificateChain certs return () else do -- Either verification failed because of an -- invalid format (with an error message), or -- the signature is wrong. In either case, -- ask the application if it wants to -- proceed, we will do that. res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) if res then do -- When verification fails, but the -- application callbacks accepts, we -- also commit the client certificate -- chain to the context. usingState_ ctx $ setClientCertificateChain certs else decryptError "verification failed" newCertReqContext :: Context -> IO CertReqContext newCertReqContext ctx = getStateRNG ctx 32 requestCertificateServer :: ServerParams -> Context -> IO Bool requestCertificateServer sparams ctx = do tls13 <- tls13orLater ctx supportsPHA <- usingState_ ctx getClientSupportsPHA let ok = tls13 && supportsPHA when ok $ do certReqCtx <- newCertReqContext ctx let certReq = makeCertRequest sparams ctx certReqCtx bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do addCertRequest13 ctx certReq sendPacket13 ctx $ Handshake13 [certReq] return ok postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO () postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do mCertReq <- getCertRequest13 ctx certCtx when (isNothing mCertReq) $ throwCore $ Error_Protocol ("unknown certificate request context", True, DecodeError) let certReq = fromJust "certReq" mCertReq -- fixme checking _ext clientCertificate sparams ctx certs baseHState <- saveHState ctx processHandshake13 ctx certReq processHandshake13 ctx h (usedHash, _, applicationSecretN) <- getRxState ctx let expectFinished hChBeforeCf (Finished13 verifyData) = do checkFinished usedHash applicationSecretN hChBeforeCf verifyData void $ restoreHState ctx baseHState expectFinished _ hs = unexpected (show hs) (Just "finished 13") -- Note: here the server could send updated NST too, however the library -- currently has no API to handle resumption and client authentication -- together, see discussion in #133 if isNullCertificateChain certs then setPendingActions ctx [ PendingActionHash False expectFinished ] else setPendingActions ctx [ PendingActionHash False (expectCertVerify sparams ctx) , PendingActionHash False expectFinished ] postHandshakeAuthServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthServerWith", True, UnexpectedMessage) tls-1.5.4/Network/TLS/Handshake/Random.hs0000644000000000000000000000543513623162342016257 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | -- Module : Network.TLS.Handshake.Random -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Random ( serverRandom , clientRandom , hrrRandom , isHelloRetryRequest , isDowngraded ) where 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 hrrRandom :: ServerRandom hrrRandom = ServerRandom $ B.pack [ 0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11 , 0xBE, 0x1D, 0x8C, 0x02, 0x1E, 0x65, 0xB8, 0x91 , 0xC2, 0xA2, 0x11, 0x16, 0x7A, 0xBB, 0x8C, 0x5E , 0x07, 0x9E, 0x09, 0xE2, 0xC8, 0xA8, 0x33, 0x9C ] isHelloRetryRequest :: ServerRandom -> Bool isHelloRetryRequest = (== hrrRandom) tls-1.5.4/Network/TLS/Handshake/Common13.hs0000644000000000000000000005006413623162342016431 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-} -- | -- Module : Network.TLS.Handshake.Common13 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Common13 ( makeFinished , checkFinished , makeServerKeyShare , makeClientKeyShare , fromServerKeyShare , makeCertVerify , checkCertVerify , makePSKBinder , replacePSKBinder , sendChangeCipherSpec13 , handshakeTerminate13 , makeCertRequest , createTLS13TicketInfo , ageToObfuscatedAge , isAgeValid , getAge , checkFreshness , getCurrentTimeFromBase , getSessionData13 , ensureNullCompression , isHashSignatureValid13 , safeNonNegative32 , RecvHandshake13M , runRecvHandshake13 , recvHandshake13 , recvHandshake13hash , CipherChoice(..) , makeCipherChoice , initEarlySecret , calculateEarlySecret , calculateHandshakeSecret , calculateApplicationSecret , calculateResumptionSecret , derivePSK ) where import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Hourglass import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Cipher 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.Process (processHandshake13) import Network.TLS.Handshake.Common (unexpected) import Network.TLS.Handshake.Key import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Handshake.Signature import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC import Network.TLS.Parameters import Network.TLS.IO import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire import Time.System import Control.Concurrent.MVar import Control.Monad.State.Strict ---------------------------------------------------------------- makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13 makeFinished ctx usedHash baseKey = Finished13 . makeVerifyData usedHash baseKey <$> transcriptHash ctx checkFinished :: MonadIO m => Hash -> ByteString -> ByteString -> ByteString -> m () checkFinished usedHash baseKey hashValue verifyData = do let verifyData' = makeVerifyData usedHash baseKey hashValue unless (verifyData' == verifyData) $ decryptError "cannot verify finished" 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, True, IllegalParameter) Right cpub -> do ecdhePair <- generateECDHEShared ctx cpub case ecdhePair of Nothing -> throwCore $ Error_Protocol (msgInvalidPublic, True, IllegalParameter) Just (spub, share) -> let wspub = IES.encodeGroupPublic spub serverKeyShare = KeyShareEntry grp wspub in return (BA.convert share, serverKeyShare) 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, True, IllegalParameter) Right spub -> case IES.groupGetShared spub cpri of Just shared -> return $ BA.convert shared Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on (EC)DH", True, IllegalParameter) 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 cc <- liftIO $ usingState_ ctx isClientContext let ctxStr | cc == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue CertVerify13 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 cc <- usingState_ ctx isClientContext let ctxStr | cc == ClientRole = serverContextString -- opposite context | otherwise = clientContextString target = makeTarget ctxStr hashValue sigParams = signatureParams pub (Just hs) checkHashSignatureValid13 hs checkSupportedHashSignature ctx (Just 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 cc <- usingState_ ctx isClientContext let sigParams = signatureParams pub (Just hs) signPrivate ctx cc sigParams target ---------------------------------------------------------------- makePSKBinder :: Context -> BaseSecret EarlySecret -> Hash -> Int -> Maybe ByteString -> IO ByteString makePSKBinder ctx (BaseSecret sec) usedHash truncLen mch = do rmsgs0 <- usingHState ctx getHandshakeMessagesRev -- fixme let rmsgs = case mch of Just ch -> trunc ch : rmsgs0 Nothing -> trunc (head rmsgs0) : tail rmsgs0 hChTruncated = hash usedHash $ B.concat $ reverse rmsgs binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "") return $ makeVerifyData usedHash binderKey hChTruncated where trunc x = B.take takeLen x where totalLen = B.length x takeLen = totalLen - truncLen replacePSKBinder :: ByteString -> ByteString -> ByteString replacePSKBinder pskz binder = identities `B.append` binders where bindersSize = B.length binder + 3 identities = B.take (B.length pskz - bindersSize) pskz binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder ---------------------------------------------------------------- sendChangeCipherSpec13 :: Context -> PacketFlightM () 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 @handshakeTerminate@, this -- does not handle session, which is managed separately for TLS 1.3. This does -- not reset byte counters because renegotiation is not allowed. And a few more -- state attributes are preserved, necessary for TLS13 handshake modes, session -- tickets and post-handshake authentication. handshakeTerminate13 :: Context -> IO () handshakeTerminate13 ctx = do -- forget most handshake data liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake -> case mhshake of Nothing -> return Nothing Just hshake -> return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) { hstServerRandom = hstServerRandom hshake , hstMasterSecret = hstMasterSecret hshake , hstNegotiatedGroup = hstNegotiatedGroup hshake , hstHandshakeDigest = hstHandshakeDigest hshake , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake , hstTLS13RTT0Status = hstTLS13RTT0Status hshake , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake } -- forget handshake data stored in TLS state usingState_ ctx $ do setTLS13KeyShare Nothing setTLS13PreSharedKey Nothing -- mark the secure connection up and running. setEstablished ctx Established ---------------------------------------------------------------- makeCertRequest :: ServerParams -> Context -> CertReqContext -> Handshake13 makeCertRequest sparams ctx certReqCtx = let sigAlgs = extensionEncode $ SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx caDns = map extractCAname $ serverCACertificates sparams caDnsEncoded = extensionEncode $ CertificateAuthorities caDns caExtension | null caDns = [] | otherwise = [ExtensionRaw extensionID_CertificateAuthorities caDnsEncoded] crexts = ExtensionRaw extensionID_SignatureAlgorithms sigAlgs : caExtension 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 life add bTime mrtt where x *+ y = x * 256 + fromIntegral y ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second ageToObfuscatedAge age tinfo = obfage where !obfage = age + ageAdd tinfo obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second obfuscatedAgeToAge obfage tinfo = age where !age = obfage - ageAdd tinfo isAgeValid :: Second -> TLS13TicketInfo -> Bool isAgeValid age tinfo = age <= lifetime tinfo * 1000 getAge :: TLS13TicketInfo -> IO Second getAge tinfo = do let clientReceiveTime = txrxTime tinfo clientSendTime <- getCurrentTimeFromBase return $! fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds checkFreshness :: TLS13TicketInfo -> Second -> IO Bool checkFreshness tinfo 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 tinfo Just rtt = estimatedRTT tinfo age = obfuscatedAgeToAge obfAge tinfo expectedArrivalTime = serverSendTime + rtt + fromIntegral age isAlive = isAgeValid age tinfo getCurrentTimeFromBase :: IO Millisecond getCurrentTimeFromBase = millisecondsFromBase <$> timeCurrentP millisecondsFromBase :: ElapsedP -> Millisecond millisecondsFromBase d = fromIntegral ms where ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns) = d - timeConvert base ms = s * 1000 + ns `div` 1000000 base = Date 2017 January 1 ---------------------------------------------------------------- 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 getNegotiatedGroup return SessionData { sessionVersion = ver , sessionCipher = cipherID usedCipher , sessionCompression = 0 , sessionClientSNI = sni , sessionSecret = psk , sessionGroup = mgrp , sessionTicketInfo = Just tinfo , sessionALPN = malpn , sessionMaxEarlyDataSize = maxSize , sessionFlags = [] } ---------------------------------------------------------------- ensureNullCompression :: MonadIO m => CompressionID -> m () ensureNullCompression compression = when (compression /= compressionID nullCompression) $ throwCore $ Error_Protocol ("compression is not allowed in TLS 1.3", True, IllegalParameter) -- Word32 is used in TLS 1.3 protocol. -- Int is used for API for Haskell TLS because it is natural. -- If Int is 64 bits, users can specify bigger number than Word32. -- If Int is 32 bits, 2^31 or larger may be converted into minus numbers. safeNonNegative32 :: (Num a, Ord a, FiniteBits a) => a -> a safeNonNegative32 x | x <= 0 = 0 | finiteBitSize x <= 32 = x | otherwise = x `min` fromIntegral (maxBound :: Word32) ---------------------------------------------------------------- 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 <- recvPacket13 ctx case epkt of Right (Handshake13 []) -> error "invalid recvPacket13 result" Right (Handshake13 (h:hs)) -> found h hs Right ChangeCipherSpec13 -> recvLoop Right x -> unexpected (show x) (Just "handshake 13") Left err -> throwCore err 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, True, IllegalParameter) isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool isHashSignatureValid13 (HashIntrinsic, s) = s `elem` [ SignatureRSApssRSAeSHA256 , SignatureRSApssRSAeSHA384 , SignatureRSApssRSAeSHA512 , SignatureEd25519 , SignatureEd448 , SignatureRSApsspssSHA256 , SignatureRSApsspssSHA384 , SignatureRSApsspssSHA512 ] isHashSignatureValid13 (h, SignatureECDSA) = h `elem` [ HashSHA256, HashSHA384, HashSHA512 ] isHashSignatureValid13 _ = False data CipherChoice = CipherChoice { cVersion :: Version , cCipher :: Cipher , cHash :: Hash , cZero :: !ByteString } makeCipherChoice :: Version -> Cipher -> CipherChoice makeCipherChoice ver cipher = CipherChoice ver cipher h zero where h = cipherHash cipher zero = B.replicate (hashDigestSize h) 0 ---------------------------------------------------------------- calculateEarlySecret :: Context -> CipherChoice -> Either ByteString (BaseSecret EarlySecret) -> Bool -> IO (SecretPair EarlySecret) calculateEarlySecret ctx choice maux initialized = do hCh <- if initialized then transcriptHash ctx else do hmsgs <- usingHState ctx getHandshakeMessages return $ hash usedHash $ B.concat hmsgs 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 = case mpsk of Just psk -> psk Nothing -> zero 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 exporterMasterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf usingState_ ctx $ setExporterMasterSecret exporterMasterSecret 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 resumptionMasterSecret = deriveSecret usedHash sec "res master" hChCf return $ BaseSecret resumptionMasterSecret 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 tls-1.5.4/Network/TLS/Handshake/Client.hs0000644000000000000000000015475513623162342016267 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Client -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Client ( handshakeClient , handshakeClientWith , postHandshakeAuthClientWith ) where import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Packet hiding (getExtensions) import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.IO import Network.TLS.Imports import Network.TLS.State import Network.TLS.Measurement import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_) import Network.TLS.Types import Network.TLS.X509 import qualified Data.ByteString as B import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict import Control.Exception (SomeException, bracket) import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Process import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Wire handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure) -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do let groups = case clientWantSessionResume cparams of Nothing -> groupsSupported Just (_, sdata) -> case sessionGroup sdata of Nothing -> [] -- TLS 1.2 or earlier Just grp -> grp : filter (/= grp) groupsSupported groupsSupported = supportedGroups (ctxSupported ctx) handshakeClient' cparams ctx groups Nothing -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a -- ClientHello when the server has responded to its ClientHello with a -- HelloRetryRequest. In that case, the client MUST send the same -- ClientHello without modification, except as follows:" -- -- So, the ClientRandom in the first client hello is necessary. handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO () handshakeClient' cparams ctx groups mparams = do updateMeasure ctx incrementNbHandshakes (crand, clientSession) <- generateClientHelloParams (rtt0, sentExtensions) <- sendClientHello clientSession crand recvServerHello clientSession sentExtensions ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $ throwCore $ Error_Protocol ("version changed after hello retry", True, IllegalParameter) -- recvServerHello sets TLS13HRR according to the server random. -- For 1st server hello, getTLS13HR returns True if it is HRR and False otherwise. -- For 2nd server hello, getTLS13HR returns False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR if ver == TLS13 then if hrr then case drop 1 groups of [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter) groups' -> do when (isJust mparams) $ throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage) mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup) | selectedGroup `elem` groups' -> do usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxState ctx let cparams' = cparams { clientEarlyData = Nothing } runPacketFlight ctx $ sendChangeCipherSpec13 ctx handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter) Just _ -> error "handshakeClient': invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure) else do handshakeClient13 cparams ctx groupToSend else do when rtt0 $ throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure) sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish ctx ClientRole else do sendClientData cparams ctx sendChangeCipherAndFinish ctx ClientRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where ciphers = supportedCiphers $ ctxSupported ctx compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMasterSec $ ctxSupported ctx groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations -- are allergic to an extension with empty data at final position. -- -- Without TLS 1.3, the list ends with extension "signature_algorithms" -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key" -- (not always present) have length > 0. getExtensions pskInfo rtt0 = sequence [ sniExtension , secureReneg , alpnExtension , emsExtension , groupExtension , ecPointExtension --, sessionTicketExtension , signatureAlgExtension --, heartbeatExtension , versionExtension , earlyDataExtension rtt0 , keyshareExtension , cookieExtension , postHandshakeAuthExtension , pskExchangeModeExtension , preSharedKeyExtension pskInfo -- MUST be last (RFC 8446) ] toExtensionRaw :: Extension e => e -> ExtensionRaw toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext) secureReneg = if supportedSecureRenegotiation $ ctxSupported ctx then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing else return Nothing alpnExtension = do mprotos <- onSuggestALPN $ clientHooks cparams case mprotos of Nothing -> return Nothing Just protos -> do usingState_ ctx $ setClientALPNSuggest protos return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos emsExtension = return $ if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx) then Nothing else Just $ toExtensionRaw ExtendedMasterSecret sniExtension = if clientUseServerNameIndication cparams then do let sni = fst $ clientServerIdentification cparams usingState_ ctx $ setClientSNI sni return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams versionExtension | tls13 = do let vers = filter (>= TLS10) $ supportedVersions $ ctxSupported ctx return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers | otherwise = return Nothing -- FIXME keyshareExtension | tls13 = case groupToSend of Nothing -> return Nothing Just grp -> do (cpri, ent) <- makeClientKeyShare ctx grp usingHState ctx $ setGroupPrivate cpri return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] | otherwise = return Nothing sessionAndCipherToResume13 = do guard tls13 (sid, sdata) <- clientWantSessionResume cparams guard (sessionVersion sdata >= TLS13) sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers return (sid, sdata, sCipher) getPskInfo = case sessionAndCipherToResume13 of Nothing -> return Nothing Just (sid, sdata, sCipher) -> do let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata age <- getAge tinfo return $ if isAgeValid age tinfo then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo) else Nothing preSharedKeyExtension pskInfo = case pskInfo of Nothing -> return Nothing Just (sid, _, choice, obfAge) -> let zero = cZero choice identity = PskIdentity sid obfAge offeredPsks = PreSharedKeyClientHello [identity] [zero] in return $ Just $ toExtensionRaw offeredPsks pskExchangeModeExtension | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] | otherwise = return Nothing earlyDataExtension rtt0 | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) | otherwise = return Nothing cookieExtension = do mcookie <- usingState_ ctx getTLS13Cookie case mcookie of Nothing -> return Nothing Just cookie -> return $ Just $ toExtensionRaw cookie postHandshakeAuthExtension | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth | otherwise = return Nothing adjustExtentions pskInfo exts ch = case pskInfo of Nothing -> return exts Just (_, sdata, choice, _) -> do let psk = sessionSecret sdata earlySecret = initEarlySecret choice (Just psk) usingHState ctx $ setTLS13EarlySecret earlySecret let ech = encodeHandshake ch h = cHash choice siz = hashDigestSize h binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) let exts' = init exts ++ [adjust (last exts)] adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders where withBinders = replacePSKBinder withoutBinders binder return exts' generateClientHelloParams = case mparams of -- Client random and session in the second client hello for -- retry must be the same as the first one. Just (crand, clientSession, _) -> return (crand, clientSession) Nothing -> do crand <- clientRandom ctx let paramSession = case clientWantSessionResume cparams of Nothing -> Session Nothing Just (sid, sdata) | sessionVersion sdata >= TLS13 -> Session Nothing | ems == RequireEMS && noSessionEMS -> Session Nothing | otherwise -> Session (Just sid) where noSessionEMS = SessionEMS `notElem` sessionFlags sdata -- In compatibility mode a client not offering a pre-TLS 1.3 -- session MUST generate a new 32-byte value if tls13 && paramSession == Session Nothing then do randomSession <- newSession ctx return (crand, randomSession) else return (crand, paramSession) sendClientHello clientSession crand = do let ver = if tls13 then TLS12 else highestVer hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer let cipherIds = map cipherID ciphers compIds = map compressionID compressions mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing pskInfo <- getPskInfo let rtt0info = pskInfo >>= get0RTTinfo rtt0 = isJust rtt0info extensions0 <- catMaybes <$> getExtensions pskInfo rtt0 extensions <- adjustExtentions pskInfo extensions0 $ mkClientHello extensions0 sendPacket ctx $ Handshake [mkClientHello extensions] mapM_ send0RTT rtt0info return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) get0RTTinfo (_, sdata, choice, _) = do earlyData <- clientEarlyData cparams guard (B.length earlyData <= sessionMaxEarlyDataSize sdata) return (choice, earlyData) send0RTT (choice, earlyData) = do let usedCipher = cCipher choice usedHash = cHash choice Just earlySecret <- usingHState ctx getTLS13EarlySecret -- Client hello is stored in hstHandshakeDigest -- But HandshakeDigestContext is not created yet. earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False let ClientTrafficSecret clientEarlySecret = pairClient earlyKey runPacketFlight ctx $ sendChangeCipherSpec13 ctx setTxState ctx usedHash usedCipher clientEarlySecret mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData usingHState ctx $ setTLS13RTT0Status RTT0Sent recvServerHello clientSession sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs -- this adds SH to hstHandshakeMessages Alert a -> case a of [(AlertLevel_Warning, UnrecognizedName)] -> if clientUseServerNameIndication cparams then return recvState else throwAlert a _ -> throwAlert a _ -> unexpected (show p) (Just "handshake") throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) -- | Store the keypair and check that it is compatible with the current protocol -- version and a list of 'CertificateType' values. storePrivInfoClient :: Context -> [CertificateType] -> Credential -> IO () storePrivInfoClient ctx cTypes (cc, privkey) = do pubkey <- storePrivInfo ctx cc privkey unless (certificateCompatible pubkey cTypes) $ throwCore $ Error_Protocol ( pubkeyType pubkey ++ " credential does not match allowed certificate types" , True , InternalError ) ver <- usingState_ ctx getVersion unless (pubkey `versionCompatible` ver) $ throwCore $ Error_Protocol ( pubkeyType pubkey ++ " credential is not supported at version " ++ show ver , True , InternalError ) -- | When the server requests a client certificate, we try to -- obtain a suitable certificate chain and private key via the -- callback in the client parameters. It is OK for the callback -- to return an empty chain, in many cases the client certificate -- is optional. If the client wishes to abort the handshake for -- lack of a suitable certificate, it can throw an exception in -- the callback. -- -- The return value is 'Nothing' when no @CertificateRequest@ was -- received and no @Certificate@ message needs to be sent. An empty -- chain means that an empty @Certificate@ message needs to be sent -- to the server, naturally without a @CertificateVerify@. A non-empty -- 'CertificateChain' is the chain to send to the server along with -- a corresponding 'CertificateVerify'. -- -- With TLS < 1.2 the server's @CertificateRequest@ does not carry -- a signature algorithm list. It has a list of supported public -- key signing algorithms in the @certificate_types@ field. The -- hash is implicit. It is 'SHA1' for DSS and 'SHA1_MD5' for RSA. -- -- With TLS == 1.2 the server's @CertificateRequest@ always has a -- @supported_signature_algorithms@ list, as a fixed component of -- the structure. This list is (wrongly) overloaded to also limit -- X.509 signatures in the client's certificate chain. The BCP -- strategy is to find a compatible chain if possible, but else -- ignore the constraint, and let the server verify the chain as it -- sees fit. The @supported_signature_algorithms@ field is only -- obligatory with respect to signatures on TLS messages, in this -- case the @CertificateVerify@ message. The @certificate_types@ -- field is still included. -- -- With TLS 1.3 the server's @CertificateRequest@ has a mandatory -- @signature_algorithms@ extension, the @signature_algorithms_cert@ -- extension, which is optional, carries a list of algorithms the -- server promises to support in verifying the certificate chain. -- As with TLS 1.2, the client's makes a /best-effort/ to deliver -- a compatible certificate chain where all the CA signatures are -- known to be supported, but it should not abort the connection -- just because the chain might not work out, just send the best -- chain you have and let the server worry about the rest. The -- supported public key algorithms are now inferred from the -- @signature_algorithms@ extension and @certificate_types@ is -- gone. -- -- With TLS 1.3, we synthesize and store a @certificate_types@ -- field at the time that the server's @CertificateRequest@ -- message is received. This is then present across all the -- protocol versions, and can be used to determine whether -- a @CertificateRequest@ was received or not. -- -- If @signature_algorithms@ is 'Nothing', then we're doing -- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension -- is optional in TLS 1.3, and so the application callback -- will not be able to distinguish between TLS 1.[01] and -- TLS 1.3 with no certificate algorithm hints, but this -- just simplifies the chain selection process, all CA -- signatures are OK. -- clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain) clientChain cparams ctx = usingHState ctx getCertReqCBdata >>= \case Nothing -> return Nothing Just cbdata -> do let callback = onCertificateRequest $ clientHooks cparams chain <- liftIO $ callback cbdata `catchException` throwMiscErrorOnException "certificate request callback failed" case chain of Nothing -> return $ Just $ CertificateChain [] Just (CertificateChain [], _) -> return $ Just $ CertificateChain [] Just cred@(cc, _) -> do let (cTypes, _, _) = cbdata storePrivInfoClient ctx cTypes cred return $ Just cc -- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with -- the local key and server's signature algorithms (both already saved). Must -- only be called for TLS versions 1.2 and up, with compatibility function -- 'signatureCompatible' or 'signatureCompatible13' based on version. -- -- The values in the server's @signature_algorithms@ extension are -- in descending order of preference. However here the algorithms -- are selected by client preference in @cHashSigs@. -- getLocalHashSigAlg :: Context -> (PubKey -> HashAndSignatureAlgorithm -> Bool) -> [HashAndSignatureAlgorithm] -> PubKey -> IO HashAndSignatureAlgorithm getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do -- Must be present with TLS 1.2 and up. (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata let want = (&&) <$> isCompatible pubKey <*> flip elem hashSigs case find want cHashSigs of Just best -> return best Nothing -> throwCore $ Error_Protocol ( keyerr pubKey , True , HandshakeFailure ) where keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" -- | Return the supported 'CertificateType' values that are -- compatible with at least one supported signature algorithm. -- supportedCtypes :: [HashAndSignatureAlgorithm] -> [CertificateType] supportedCtypes hashAlgs = nub $ foldr ctfilter [] hashAlgs where ctfilter x acc = case hashSigToCertType x of Just cType | cType <= lastSupportedCertificateType -> cType : acc _ -> acc -- clientSupportedCtypes :: Context -> [CertificateType] clientSupportedCtypes ctx = supportedCtypes $ supportedHashSignatures $ ctxSupported ctx -- sigAlgsToCertTypes :: Context -> [HashAndSignatureAlgorithm] -> [CertificateType] sigAlgsToCertTypes ctx hashSigs = filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx -- | TLS 1.2 and below. Send the client handshake messages that -- follow the @ServerHello@, etc. except for @CCS@ and @Finished@. -- -- XXX: Is any buffering done here to combined these messages into -- a single TCP packet? Otherwise we're prone to Nagle delays, or -- in any case needlessly generate multiple small packets, where -- a single larger packet will do. The TLS 1.3 code path seems -- to separating record generation and transmission and sending -- multiple records in a single packet. -- -- -> [certificate] -- -> client key exchange -- -> [cert verify] sendClientData :: ClientParams -> Context -> IO () sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify where sendCertificate = do usingHState ctx $ setClientCertSent False clientChain cparams ctx >>= \case Nothing -> return () Just cc@(CertificateChain certs) -> do unless (null certs) $ usingHState ctx $ setClientCertSent True sendPacket ctx $ Handshake [Certificates cc] sendClientKeyXchg = do cipher <- usingHState ctx getPendingCipher (ckx, setMasterSec) <- case cipherKeyExchange cipher of CipherKeyExchange_RSA -> do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 let premaster = encodePreMasterSecret clientVersion prerand setMasterSec = setMasterSecretFromPre xver ClientRole premaster encryptedPreMaster <- do -- SSL3 implementation generally forget this length field since it's redundant, -- however TLS10 make it clear that the length field need to be present. e <- encryptRSA ctx premaster let extra = if xver < TLS10 then B.empty else encodeWord16 $ fromIntegral $ B.length e return $ extra `B.append` e return (CKX_RSA encryptedPreMaster, setMasterSec) CipherKeyExchange_DHE_RSA -> getCKX_DHE CipherKeyExchange_DHE_DSS -> getCKX_DHE CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure) sendPacket ctx $ Handshake [ClientKeyXchg ckx] masterSecret <- usingHState ctx setMasterSec logKey ctx (MasterSecret masterSecret) where getCKX_DHE = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams ffGroup = findFiniteFieldGroup params srvpub = serverDHParamsToPublic serverParams unless (maybe False (isSupportedGroup ctx) ffGroup) $ do groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException` throwMiscErrorOnException "custom group callback failed" case groupUsage of GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity) GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure) GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, IllegalParameter) GroupUsageValid -> return () -- When grp is known but not in the supported list we use it -- anyway. This provides additional validation and a more -- efficient implementation. (clientDHPub, premaster) <- case ffGroup of Nothing -> do (clientDHPriv, clientDHPub) <- generateDHE ctx params let premaster = dhGetShared params clientDHPriv srvpub return (clientDHPub, premaster) Just grp -> do usingHState ctx $ setNegotiatedGroup grp dhePair <- generateFFDHEShared ctx grp srvpub case dhePair of Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just pair -> return pair let setMasterSec = setMasterSecretFromPre xver ClientRole premaster return (CKX_DH clientDHPub, setMasterSec) getCKX_ECDHE = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setNegotiatedGroup grp ecdhePair <- generateECDHEShared ctx srvpub case ecdhePair of Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion let setMasterSec = setMasterSecretFromPre xver ClientRole premaster return (CKX_ECDH $ encodeGroupPublic clipub, setMasterSec) -- In order to send a proper certificate verify message, -- we have to do the following: -- -- 1. Determine which signing algorithm(s) the server supports -- (we currently only support RSA). -- 2. Get the current handshake hash from the handshake state. -- 3. Sign the handshake hash -- 4. Send it to the server. -- sendCertificateVerify = do ver <- usingState_ ctx getVersion -- Only send a certificate verify message when we -- have sent a non-empty list of certificates. -- certSent <- usingHState ctx getClientCertSent when certSent $ do pubKey <- getLocalPublicKey ctx mhashSig <- case ver of TLS12 -> let cHashSigs = supportedHashSignatures $ ctxSupported ctx in Just <$> getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs sendPacket ctx $ Handshake [CertVerify sigDig] processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw extID content) | extID == extensionID_SecureRenegotiation = do cv <- getVerifiedData ClientRole sv <- getVerifiedData ServerRole let bs = extensionEncode (SecureRenegotiation cv $ Just sv) unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of Just (SupportedVersionsServerHello ver) -> setVersion ver _ -> return () | extID == extensionID_KeyShare = do hrr <- getTLS13HRR let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello setTLS13KeyShare $ extensionDecode msgt content | extID == extensionID_PreSharedKey = setTLS13PreSharedKey $ extensionDecode MsgTServerHello content processServerExtension _ = return () throwMiscErrorOnException :: String -> SomeException -> IO a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e -- | onServerHello process the ServerHello message on the client. -- -- 1) check the version chosen by the server is one allowed by parameters. -- 2) check that our compression and cipher algorithms are part of the list we sent -- 3) check extensions received are part of the one we sent -- 4) process the session parameter to see if the server want to start a new session or can resume -- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher -- onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) -- find the compression and cipher methods that the server want to use. cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, IllegalParameter) Just alg -> return alg compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter) Just alg -> return alg -- intersect sent extensions in client and the received extensions from server. -- if server returns extensions that we didn't request, fail. let checkExt (ExtensionRaw i _) | i == extensionID_Cookie = False -- for HRR | otherwise = i `notElem` sentExts when (any checkExt exts) $ throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) let resumingSession = case clientWantSessionResume cparams of Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing Nothing -> Nothing isHRR = isHelloRetryRequest serverRan usingState_ ctx $ do setTLS13HRR isHRR setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello) setSession serverSession (isJust resumingSession) setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension exts setALPN ctx MsgTServerHello exts ver <- usingState_ ctx getVersion -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3 -- in the supported_versions extension, *AND ALSO* set the TLS 1.2 -- downgrade signal in the server random. If we support TLS 1.3 and -- actually negotiate TLS 1.3, we must ignore the server random downgrade -- signal. Therefore, 'isDowngraded' needs to take into account the -- negotiated version and the server random, as well as the list of -- client-side enabled protocol versions. -- when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $ throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter) case find (== ver) (supportedVersions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion) Just _ -> return () if ver > TLS12 then do when (serverSession /= clientSession) $ throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter) established <- ctxEstablished ctx eof <- ctxEOF ctx when (established == Established && not eof) $ throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion) ensureNullCompression compression failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg return RecvStateDone else do ems <- processExtendedMasterSec ctx ver MsgTServerHello exts usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg case resumingSession of Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) Just sessionData -> do let emsSession = SessionEMS `elem` sessionFlags sessionData when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent" in throwCore $ Error_Protocol (err, True, HandshakeFailure) let masterSecret = sessionSecret sessionData usingHState ctx $ setMasterSecret rver ClientRole masterSecret logKey ctx (MasterSecret masterSecret) return $ RecvStateNext expectChangeCipher onServerHello _ _ _ _ p = unexpected (show p) (Just "server hello") processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do when (isNullCertificateChain certs) $ throwCore $ Error_Protocol ("server certificate missing", True, DecodeError) -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of CertificateUsageAccept -> checkLeafCertificateKeyUsage CertificateUsageReject reason -> certificateRejected reason return $ RecvStateHandshake (processServerKeyExchange ctx) where shared = clientShared cparams checkCert = onServerCertificate (clientHooks cparams) (sharedCAStore shared) (sharedValidationCache shared) (clientServerIdentification cparams) certs -- also verify that the certificate optional key usage is compatible -- with the intended key-exchange. This check is not delegated to -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated -- cipher, which is not available from onServerCertificate parameters. -- Additionally, with only one shared ValidationCache, x509-validation -- would cache validation result based on a key usage and reuse it with -- another key usage. checkLeafCertificateKeyUsage = do cipher <- usingHState ctx getPendingCipher case requiredCertKeyUsage cipher of [] -> return () flags -> verifyLeafKeyUsage flags certs processCertificate _ ctx p = processServerKeyExchange ctx p expectChangeCipher :: Packet -> IO (RecvState IO) expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish :: Handshake -> IO (RecvState IO) expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) processServerKeyExchange ctx (ServerKeyXchg origSkx) = do cipher <- usingHState ctx getPendingCipher processWithCipher cipher origSkx return $ RecvStateHandshake (processCertificateRequest ctx) where processWithCipher cipher skx = case (cipherKeyExchange cipher, skx) of (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> doDHESignature dhparams signature KX_RSA (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> doDHESignature dhparams signature KX_DSS (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> doECDHESignature ecdhparams signature KX_RSA (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> doECDHESignature ecdhparams signature KX_ECDSA (cke, SKX_Unparsed bytes) -> do ver <- usingState_ ctx getVersion case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure) Right realSkx -> processWithCipher cipher realSkx -- we need to resolve the result. and recall processWithCipher .. (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) doDHESignature dhparams signature kxsAlg = do -- FF group selected by the server is verified when generating CKX publicKey <- getSignaturePublicKey kxsAlg verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature kxsAlg = do -- EC group selected by the server is verified when generating CKX publicKey <- getSignaturePublicKey kxsAlg verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams") usingHState ctx $ setServerECDHParams ecdhparams getSignaturePublicKey kxsAlg = do publicKey <- usingHState ctx getRemotePublicKey unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure) ver <- usingState_ ctx getVersion unless (publicKey `versionCompatible` ver) $ throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey, True, IllegalParameter) let groups = supportedGroups (ctxSupported ctx) unless (satisfiesEcPredicate (`elem` groups) publicKey) $ throwCore $ Error_Protocol ("server public key has unsupported elliptic curve", True, IllegalParameter) return publicKey processServerKeyExchange ctx p = processCertificateRequest ctx p processCertificateRequest :: Context -> Handshake -> IO (RecvState IO) processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do ver <- usingState_ ctx getVersion when (ver == TLS12 && isNothing sigAlgs) $ throwCore $ Error_Protocol ( "missing TLS 1.2 certificate request signature algorithms" , True , InternalError ) let cTypes = filter (<= lastSupportedCertificateType) cTypesSent usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames) return $ RecvStateHandshake (processServerHelloDone ctx) processCertificateRequest ctx p = do usingHState ctx $ setCertReqCBdata Nothing processServerHelloDone ctx p processServerHelloDone :: Context -> Handshake -> IO (RecvState m) processServerHelloDone _ ServerHelloDone = return RecvStateDone processServerHelloDone _ p = unexpected (show p) (Just "server hello data") -- Unless result is empty, server certificate must be allowed for at least one -- of the returned values. Constraints for RSA-based key exchange are relaxed -- to avoid rejecting certificates having incomplete extension. requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag] requiredCertKeyUsage cipher = case cipherKeyExchange cipher of CipherKeyExchange_RSA -> rsaCompatibility CipherKeyExchange_DH_Anon -> [] -- unrestricted CipherKeyExchange_DHE_RSA -> rsaCompatibility CipherKeyExchange_ECDHE_RSA -> rsaCompatibility CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ] CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ] CipherKeyExchange_DH_RSA -> rsaCompatibility CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ] CipherKeyExchange_ECDH_RSA -> rsaCompatibility CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ] CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ] where rsaCompatibility = [ KeyUsage_digitalSignature , KeyUsage_keyEncipherment , KeyUsage_keyAgreement ] handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO () handshakeClient13 cparams ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher handshakeClient13' cparams ctx groupSent choice handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO () handshakeClient13' cparams ctx groupSent choice = do (_, hkey, resuming) <- switchToHandshakeSecret let handshakeSecret = triBase hkey ClientTrafficSecret clientHandshakeSecret = triClient hkey ServerTrafficSecret serverHandshakeSecret = triServer hkey rtt0accepted <- runRecvHandshake13 $ do accepted <- recvHandshake13 ctx expectEncryptedExtensions unless resuming $ recvHandshake13 ctx expectCertRequest recvHandshake13hash ctx $ expectFinished serverHandshakeSecret return accepted hChSf <- transcriptHash ctx runPacketFlight ctx $ sendChangeCipherSpec13 ctx when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) setTxState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret appKey <- switchToApplicationSecret handshakeSecret hChSf let applicationSecret = triBase appKey setResumptionSecret applicationSecret handshakeTerminate13 ctx where usedCipher = cCipher choice usedHash = cHash choice hashSize = hashDigestSize usedHash switchToHandshakeSecret = do ensureRecvComplete ctx ecdhe <- calcSharedKey (earlySecret, resuming) <- makeEarlySecret handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe let ServerTrafficSecret serverHandshakeSecret = triServer handKey setRxState ctx usedHash usedCipher serverHandshakeSecret return (usedCipher, handKey, resuming) switchToApplicationSecret handshakeSecret hChSf = do ensureRecvComplete ctx appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf let ServerTrafficSecret serverApplicationSecret0 = triServer appKey let ClientTrafficSecret clientApplicationSecret0 = triClient appKey setTxState ctx usedHash usedCipher clientApplicationSecret0 setRxState ctx usedHash usedCipher serverApplicationSecret0 return appKey calcSharedKey = do serverKeyShare <- do mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareServerHello ks) -> return ks Just _ -> error "calcSharedKey: invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) let grp = keyShareEntryGroup serverKeyShare unless (groupSent == Just grp) $ throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter) usingHState ctx $ setNegotiatedGroup grp usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare makeEarlySecret = do mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret case mEarlySecretPSK of Nothing -> return (initEarlySecret choice Nothing, False) Just earlySecretPSK@(BaseSecret sec) -> do mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey case mSelectedIdentity of Nothing -> return (initEarlySecret choice Nothing, False) Just (PreSharedKeyServerHello 0) -> do unless (B.length sec == hashSize) $ throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter) usingHState ctx $ setTLS13HandshakeMode PreSharedKey return (earlySecretPSK, True) Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter) expectEncryptedExtensions (EncryptedExtensions13 eexts) = do liftIO $ setALPN ctx MsgTEncryptedExtensions eexts st <- usingHState ctx getTLS13RTT0Status if st == RTT0Sent then case extensionLookup extensionID_EarlyData eexts of Just _ -> do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted return True Nothing -> do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Rejected return False else return False expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions") expectCertRequest (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx expectCertAndVerify expectCertRequest other = do usingHState ctx $ do setCertReqToken Nothing setCertReqCBdata Nothing -- setCertReqSigAlgsCert Nothing expectCertAndVerify other expectCertAndVerify (Certificate13 _ cc _) = do _ <- liftIO $ processCertificate cparams ctx (Certificates cc) let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey recvHandshake13hash ctx $ expectCertVerify pubkey expectCertAndVerify p = unexpected (show p) (Just "server certificate") expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") expectFinished baseKey hashValue (Finished13 verifyData) = checkFinished usedHash baseKey hashValue verifyData expectFinished _ _ p = unexpected (show p) (Just "server finished") setResumptionSecret applicationSecret = do resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret usingHState ctx $ setTLS13ResumptionSecret resumptionSecret processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () processCertRequest13 ctx token exts = do let hsextID = extensionID_SignatureAlgorithms -- caextID = extensionID_SignatureAlgorithmsCert dNames <- canames -- The @signature_algorithms@ extension is mandatory. hsAlgs <- extalgs hsextID unsighash cTypes <- case hsAlgs of Just as -> let validAs = filter isHashSignatureValid13 as in return $ sigAlgsToCertTypes ctx validAs Nothing -> throwCore $ Error_Protocol ( "invalid certificate request" , True , HandshakeFailure ) -- Unused: -- caAlgs <- extalgs caextID uncertsig usingHState ctx $ do setCertReqToken $ Just token setCertReqCBdata $ Just (cTypes, hsAlgs, dNames) -- setCertReqSigAlgsCert caAlgs where canames = case extensionLookup extensionID_CertificateAuthorities exts of Nothing -> return [] Just ext -> case extensionDecode MsgTCertificateRequest ext of Just (CertificateAuthorities names) -> return names _ -> throwCore $ Error_Protocol ( "invalid certificate request" , True , HandshakeFailure ) extalgs extID decons = case extensionLookup extID exts of Nothing -> return Nothing Just ext -> case extensionDecode MsgTCertificateRequest ext of Just e -> return $ decons e _ -> throwCore $ Error_Protocol ( "invalid certificate request" , True , HandshakeFailure ) unsighash :: SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm] unsighash (SignatureAlgorithms a) = Just a {- Unused for now uncertsig :: SignatureAlgorithmsCert -> Maybe [HashAndSignatureAlgorithm] uncertsig (SignatureAlgorithmsCert a) = Just a -} sendClientFlight13 :: ClientParams -> Context -> Hash -> ByteString -> IO () sendClientFlight13 cparams ctx usedHash baseKey = do chain <- clientChain cparams ctx runPacketFlight ctx $ do case chain of Nothing -> return () Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc rawFinished <- makeFinished ctx usedHash baseKey loadPacket13 ctx $ Handshake13 [rawFinished] where sendClientData13 chain (Just token) = do let (CertificateChain certs) = chain certExts = replicate (length certs) [] cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts] case certs of [] -> return () _ -> do hChSc <- transcriptHash ctx pubKey <- getLocalPublicKey ctx sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc loadPacket13 ctx $ Handshake13 [vfy] -- sendClientData13 _ _ = throwCore $ Error_Protocol ( "missing TLS 1.3 certificate request context token" , True , InternalError ) setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of Just protos -> when (proto `elem` protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return () _ -> return () postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do processHandshake13 ctx h processCertRequest13 ctx certReqCtx exts (usedHash, _, applicationSecretN) <- getTxState ctx sendClientFlight13 cparams ctx usedHash applicationSecretN postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage) tls-1.5.4/Network/TLS/Handshake/Key.hs0000644000000000000000000001613513623162342015566 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Network.TLS.Handshake.Key -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- functions for RSA operations -- module Network.TLS.Handshake.Key ( encryptRSA , signPrivate , decryptRSA , verifyPublic , generateDHE , generateECDHE , generateECDHEShared , generateFFDHE , generateFFDHEShared , versionCompatible , isDigitalSignaturePair , checkDigitalSignatureKey , getLocalPublicKey , satisfiesEcPredicate , logKey ) where import Control.Monad.State.Strict import qualified Data.ByteString as B import Network.TLS.Handshake.State import Network.TLS.State (withRNG, getVersion) import Network.TLS.Crypto import Network.TLS.Types import Network.TLS.Context.Internal import Network.TLS.Imports import Network.TLS.Struct 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 ver <- getVersion let cipher = if ver < TLS10 then econtent else 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 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 -- | 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", True, HandshakeFailure) unless (key `versionCompatible` usedVersion) $ throwCore $ Error_Protocol (show usedVersion ++ " has no support for " ++ pubkeyType key, True, 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 --(PubKeyECDSA _, PrivKeyECDSA _) -> True (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 MasterSecret where labelAndKey (MasterSecret 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 . tail . showBytesHex tls-1.5.4/Network/TLS/Extra/0000755000000000000000000000000013623162342013671 5ustar0000000000000000tls-1.5.4/Network/TLS/Extra/Cipher.hs0000644000000000000000000011714413623162342015447 0ustar0000000000000000-- | -- Module : Network.TLS.Extra.Cipher -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Extra.Cipher ( -- * cipher suite ciphersuite_default , ciphersuite_all , ciphersuite_medium , ciphersuite_strong , ciphersuite_unencrypted , ciphersuite_dhe_rsa , ciphersuite_dhe_dss -- * individual ciphers , cipher_null_SHA1 , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_AES128_SHA256 , cipher_AES256_SHA256 , cipher_AES128CCM_SHA256 , cipher_AES128CCM8_SHA256 , cipher_AES128GCM_SHA256 , cipher_AES256CCM_SHA256 , cipher_AES256CCM8_SHA256 , cipher_AES256GCM_SHA384 , cipher_DHE_RSA_AES128_SHA1 , cipher_DHE_RSA_AES256_SHA1 , cipher_DHE_RSA_AES128_SHA256 , cipher_DHE_RSA_AES256_SHA256 , cipher_DHE_DSS_AES128_SHA1 , cipher_DHE_DSS_AES256_SHA1 , cipher_DHE_RSA_AES128CCM_SHA256 , cipher_DHE_RSA_AES128CCM8_SHA256 , cipher_DHE_RSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256CCM_SHA256 , cipher_DHE_RSA_AES256CCM8_SHA256 , cipher_DHE_RSA_AES256GCM_SHA384 , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA256 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_ECDHE_RSA_AES256CBC_SHA , cipher_ECDHE_RSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_ECDSA_AES128CBC_SHA , cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_ECDSA_AES128CBC_SHA256 , cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_ECDSA_AES128CCM_SHA256 , cipher_ECDHE_ECDSA_AES128CCM8_SHA256 , cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_ECDHE_ECDSA_AES256CCM_SHA256 , cipher_ECDHE_ECDSA_AES256CCM8_SHA256 , cipher_ECDHE_ECDSA_AES256GCM_SHA384 , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 -- TLS 1.3 , cipher_TLS13_AES128GCM_SHA256 , cipher_TLS13_AES256GCM_SHA384 , cipher_TLS13_CHACHA20POLY1305_SHA256 , cipher_TLS13_AES128CCM_SHA256 , cipher_TLS13_AES128CCM8_SHA256 -- * obsolete and non-standard ciphers , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 , cipher_null_MD5 , cipher_DHE_DSS_RC4_SHA1 ) where import qualified Data.ByteString as B import Network.TLS.Types (Version(..)) import Network.TLS.Cipher import Network.TLS.Imports import Data.Tuple (swap) import Crypto.Cipher.AES import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 import qualified Crypto.Cipher.RC4 as RC4 import Crypto.Cipher.TripleDES import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error import qualified Crypto.MAC.Poly1305 as Poly1305 takelast :: Int -> B.ByteString -> B.ByteString takelast i b = B.drop (B.length b - i) b aes128cbc :: BulkDirection -> BulkKey -> BulkBlock aes128cbc BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\iv input -> let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)) aes128cbc BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\iv input -> let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)) aes256cbc :: BulkDirection -> BulkKey -> BulkBlock aes256cbc BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\iv input -> let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)) aes256cbc BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\iv input -> let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)) aes128ccm :: BulkDirection -> BulkKey -> BulkAEAD aes128ccm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in swap $ aeadSimpleEncrypt aeadIni ad d 16) aes128ccm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in simpleDecrypt aeadIni ad d 16) aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD aes128ccm8 BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in swap $ aeadSimpleEncrypt aeadIni ad d 8) aes128ccm8 BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in simpleDecrypt aeadIni ad d 8) aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD aes128gcm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) in swap $ aeadSimpleEncrypt aeadIni ad d 16) aes128gcm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) in simpleDecrypt aeadIni ad d 16) aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD aes256ccm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in swap $ aeadSimpleEncrypt aeadIni ad d 16) aes256ccm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in simpleDecrypt aeadIni ad d 16) aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD aes256ccm8 BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in swap $ aeadSimpleEncrypt aeadIni ad d 8) aes256ccm8 BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 aeadIni = noFail (aeadInit mode ctx nonce) in simpleDecrypt aeadIni ad d 8) aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD aes256gcm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) in swap $ aeadSimpleEncrypt aeadIni ad d 16) aes256gcm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) in simpleDecrypt aeadIni ad d 16) simpleDecrypt :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag) simpleDecrypt aeadIni header input taglen = (output, tag) where aead = aeadAppendHeader aeadIni header (output, aeadFinal) = aeadDecrypt aead input tag = aeadFinalize aeadFinal taglen noFail :: CryptoFailable a -> a noFail = throwCryptoError makeIV_ :: BlockCipher a => B.ByteString -> IV a makeIV_ = fromMaybe (error "makeIV_") . makeIV tripledes_ede :: BulkDirection -> BulkKey -> BulkBlock tripledes_ede BulkEncrypt key = let ctx = noFail $ cipherInit key in (\iv input -> let output = cbcEncrypt ctx (tripledes_iv iv) input in (output, takelast 8 output)) tripledes_ede BulkDecrypt key = let ctx = noFail $ cipherInit key in (\iv input -> let output = cbcDecrypt ctx (tripledes_iv iv) input in (output, takelast 8 input)) tripledes_iv :: BulkIV -> IV DES_EDE3 tripledes_iv iv = fromMaybe (error "tripledes cipher iv internal error") $ makeIV iv rc4 :: BulkDirection -> BulkKey -> BulkStream rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey) where combineRC4 ctx input = let (ctx', output) = RC4.combine ctx input in (output, BulkStream (combineRC4 ctx')) chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD chacha20poly1305 BulkEncrypt key nonce = let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) in (\input ad -> let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) (output, st3) = ChaChaPoly1305.encrypt input st2 Poly1305.Auth tag = ChaChaPoly1305.finalize st3 in (output, AuthTag tag)) chacha20poly1305 BulkDecrypt key nonce = let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) in (\input ad -> let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) (output, st3) = ChaChaPoly1305.decrypt input st2 Poly1305.Auth tag = ChaChaPoly1305.finalize st3 in (output, AuthTag tag)) -- | 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, with the ChaCha20-Poly1305 variant placed just -- after. -- -- The CCM ciphers all come together after the GCM variants due to their -- relative performance cost. ciphersuite_default :: [Cipher] ciphersuite_default = [ -- First the PFS + GCM + SHA2 ciphers cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384 , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384 , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , -- Next the PFS + CCM + SHA2 ciphers cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256 , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256 -- Next the PFS + CBC + SHA2 ciphers , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384 , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256 -- Next the PFS + CBC + SHA1 ciphers , cipher_ECDHE_ECDSA_AES128CBC_SHA, cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_RSA_AES128CBC_SHA, cipher_ECDHE_RSA_AES256CBC_SHA , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1 -- Next the non-PFS + GCM + SHA2 ciphers , cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384 -- Next the non-PFS + CCM + SHA2 ciphers , cipher_AES128CCM_SHA256, cipher_AES256CCM_SHA256 -- Next the non-PFS + CBC + SHA2 ciphers , cipher_AES256_SHA256, cipher_AES128_SHA256 -- Next the non-PFS + CBC + SHA1 ciphers , cipher_AES256_SHA1, cipher_AES128_SHA1 -- Nobody uses or should use DSS, RC4, 3DES or MD5 -- , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 -- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 -- , cipher_RSA_3DES_EDE_CBC_SHA1 -- TLS13 (listed at the end but version is negotiated first) , cipher_TLS13_AES128GCM_SHA256 , cipher_TLS13_AES256GCM_SHA384 , cipher_TLS13_CHACHA20POLY1305_SHA256 , cipher_TLS13_AES128CCM_SHA256 ] {-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} -- | The default ciphersuites + some not recommended last resort ciphers. ciphersuite_all :: [Cipher] ciphersuite_all = ciphersuite_default ++ [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256, cipher_ECDHE_ECDSA_AES256CCM8_SHA256 , cipher_DHE_RSA_AES128CCM8_SHA256, cipher_DHE_RSA_AES256CCM8_SHA256 , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 , cipher_AES128CCM8_SHA256, cipher_AES256CCM8_SHA256 , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_RC4_128_SHA1 , cipher_TLS13_AES128CCM8_SHA256 ] {-# DEPRECATED ciphersuite_medium "Use ciphersuite_strong or ciphersuite_default instead." #-} -- | list of medium ciphers. ciphersuite_medium :: [Cipher] ciphersuite_medium = [ cipher_RC4_128_SHA1 , cipher_AES128_SHA1 ] -- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we -- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305 -- variants. For weaker constructs, we use just the AES256 form. -- -- The CCM ciphers come just after the corresponding GCM ciphers despite their -- relative performance cost. ciphersuite_strong :: [Cipher] ciphersuite_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256 cipher_ECDHE_ECDSA_AES256GCM_SHA384, cipher_ECDHE_ECDSA_AES256CCM_SHA256 , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES128CCM_SHA256 , cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES256CCM_SHA256 , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES128CCM_SHA256 -- No AEAD , cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_AES256CBC_SHA384 , cipher_DHE_RSA_AES256_SHA256 -- No SHA2 , cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_RSA_AES256CBC_SHA , cipher_DHE_RSA_AES256_SHA1 -- No PFS , cipher_AES256GCM_SHA384 , cipher_AES256CCM_SHA256 -- Neither PFS nor AEAD, just SHA2 , cipher_AES256_SHA256 -- Last resort no PFS, AEAD or SHA2 , cipher_AES256_SHA1 -- TLS13 (listed at the end but version is negotiated first) , cipher_TLS13_AES256GCM_SHA384 , cipher_TLS13_CHACHA20POLY1305_SHA256 , cipher_TLS13_AES128GCM_SHA256 , cipher_TLS13_AES128CCM_SHA256 ] -- | DHE-RSA cipher suite. This only includes ciphers bound specifically to -- DHE-RSA so TLS 1.3 ciphers must be added separately. ciphersuite_dhe_rsa :: [Cipher] ciphersuite_dhe_rsa = [ cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES256CCM_SHA256 , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES128CCM_SHA256 , cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1 ] ciphersuite_dhe_dss :: [Cipher] ciphersuite_dhe_dss = [cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1, cipher_DHE_DSS_RC4_SHA1] -- | all unencrypted ciphers, do not use on insecure network. ciphersuite_unencrypted :: [Cipher] ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] bulk_null, bulk_rc4, bulk_aes128, bulk_aes256, bulk_tripledes_ede, bulk_aes128gcm, bulk_aes256gcm :: Bulk bulk_aes128ccm, bulk_aes128ccm8, bulk_aes256ccm, bulk_aes256ccm8, bulk_chacha20poly1305 :: Bulk bulk_null = Bulk { bulkName = "null" , bulkKeySize = 0 , bulkIVSize = 0 , bulkExplicitIV = 0 , bulkAuthTagLen = 0 , bulkBlockSize = 0 , bulkF = BulkStreamF passThrough } where passThrough _ _ = BulkStream go where go inp = (inp, BulkStream go) bulk_rc4 = Bulk { bulkName = "RC4-128" , bulkKeySize = 16 , bulkIVSize = 0 , bulkExplicitIV = 0 , bulkAuthTagLen = 0 , bulkBlockSize = 0 , bulkF = BulkStreamF rc4 } bulk_aes128 = Bulk { bulkName = "AES128" , bulkKeySize = 16 , bulkIVSize = 16 , bulkExplicitIV = 0 , bulkAuthTagLen = 0 , bulkBlockSize = 16 , bulkF = BulkBlockF aes128cbc } bulk_aes128ccm = Bulk { bulkName = "AES128CCM" , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length , bulkExplicitIV = 8 , bulkAuthTagLen = 16 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF aes128ccm } bulk_aes128ccm8 = Bulk { bulkName = "AES128CCM8" , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length , bulkExplicitIV = 8 , bulkAuthTagLen = 8 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF aes128ccm8 } bulk_aes128gcm = Bulk { bulkName = "AES128GCM" , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length , bulkExplicitIV = 8 , bulkAuthTagLen = 16 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF aes128gcm } bulk_aes256ccm = Bulk { bulkName = "AES256CCM" , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length , bulkExplicitIV = 8 , bulkAuthTagLen = 16 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF aes256ccm } bulk_aes256ccm8 = Bulk { bulkName = "AES256CCM8" , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length , bulkExplicitIV = 8 , bulkAuthTagLen = 8 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF aes256ccm8 } bulk_aes256gcm = Bulk { bulkName = "AES256GCM" , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length , bulkExplicitIV = 8 , bulkAuthTagLen = 16 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF aes256gcm } bulk_aes256 = Bulk { bulkName = "AES256" , bulkKeySize = 32 , bulkIVSize = 16 , bulkExplicitIV = 0 , bulkAuthTagLen = 0 , bulkBlockSize = 16 , bulkF = BulkBlockF aes256cbc } bulk_tripledes_ede = Bulk { bulkName = "3DES-EDE-CBC" , bulkKeySize = 24 , bulkIVSize = 8 , bulkExplicitIV = 0 , bulkAuthTagLen = 0 , bulkBlockSize = 8 , bulkF = BulkBlockF tripledes_ede } bulk_chacha20poly1305 = Bulk { bulkName = "CHACHA20POLY1305" , bulkKeySize = 32 , bulkIVSize = 12 -- RFC 7905 section 2, fixed_iv_length , bulkExplicitIV = 0 , bulkAuthTagLen = 16 , bulkBlockSize = 0 -- dummy, not used , bulkF = BulkAeadF chacha20poly1305 } -- TLS13 bulks are same as TLS12 except they never have explicit IV bulk_aes128gcm_13, bulk_aes256gcm_13, bulk_aes128ccm_13, bulk_aes128ccm8_13 :: Bulk bulk_aes128gcm_13 = bulk_aes128gcm { bulkIVSize = 12, bulkExplicitIV = 0 } bulk_aes256gcm_13 = bulk_aes256gcm { bulkIVSize = 12, bulkExplicitIV = 0 } bulk_aes128ccm_13 = bulk_aes128ccm { bulkIVSize = 12, bulkExplicitIV = 0 } bulk_aes128ccm8_13 = bulk_aes128ccm8 { bulkIVSize = 12, bulkExplicitIV = 0 } -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher { cipherID = 0x0001 , cipherName = "RSA-null-MD5" , cipherBulk = bulk_null , cipherHash = MD5 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | unencrypted cipher using RSA for key exchange and SHA1 for digest cipher_null_SHA1 :: Cipher cipher_null_SHA1 = Cipher { cipherID = 0x0002 , cipherName = "RSA-null-SHA1" , cipherBulk = bulk_null , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | RC4 cipher, RSA key exchange and MD5 for digest cipher_RC4_128_MD5 :: Cipher cipher_RC4_128_MD5 = Cipher { cipherID = 0x0004 , cipherName = "RSA-rc4-128-md5" , cipherBulk = bulk_rc4 , cipherHash = MD5 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | RC4 cipher, RSA key exchange and SHA1 for digest cipher_RC4_128_SHA1 :: Cipher cipher_RC4_128_SHA1 = Cipher { cipherID = 0x0005 , cipherName = "RSA-rc4-128-sha1" , cipherBulk = bulk_rc4 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | 3DES cipher (168 bit key), RSA key exchange and SHA1 for digest cipher_RSA_3DES_EDE_CBC_SHA1 :: Cipher cipher_RSA_3DES_EDE_CBC_SHA1 = Cipher { cipherID = 0x000A , cipherName = "RSA-3DES-EDE-CBC-SHA1" , cipherBulk = bulk_tripledes_ede , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest cipher_AES128_SHA1 :: Cipher cipher_AES128_SHA1 = Cipher { cipherID = 0x002F , cipherName = "RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just SSL3 } -- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest cipher_DHE_DSS_AES128_SHA1 :: Cipher cipher_DHE_DSS_AES128_SHA1 = Cipher { cipherID = 0x0032 , cipherName = "DHE-DSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_DHE_DSS , cipherMinVer = Nothing } -- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES128_SHA1 :: Cipher cipher_DHE_RSA_AES128_SHA1 = Cipher { cipherID = 0x0033 , cipherName = "DHE-RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Nothing } -- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest cipher_AES256_SHA1 :: Cipher cipher_AES256_SHA1 = Cipher { cipherID = 0x0035 , cipherName = "RSA-AES256-SHA1" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just SSL3 } -- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest cipher_DHE_DSS_AES256_SHA1 :: Cipher cipher_DHE_DSS_AES256_SHA1 = cipher_DHE_DSS_AES128_SHA1 { cipherID = 0x0038 , cipherName = "DHE-DSA-AES256-SHA1" , cipherBulk = bulk_aes256 } -- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES256_SHA1 :: Cipher cipher_DHE_RSA_AES256_SHA1 = cipher_DHE_RSA_AES128_SHA1 { cipherID = 0x0039 , cipherName = "DHE-RSA-AES256-SHA1" , cipherBulk = bulk_aes256 } -- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest cipher_AES128_SHA256 :: Cipher cipher_AES128_SHA256 = Cipher { cipherID = 0x003C , cipherName = "RSA-AES128-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } -- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest cipher_AES256_SHA256 :: Cipher cipher_AES256_SHA256 = Cipher { cipherID = 0x003D , cipherName = "RSA-AES256-SHA256" , cipherBulk = bulk_aes256 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } -- This is not registered in IANA. -- So, this will be removed in the next major release. cipher_DHE_DSS_RC4_SHA1 :: Cipher cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 { cipherID = 0x0066 , cipherName = "DHE-DSA-RC4-SHA1" , cipherBulk = bulk_rc4 } cipher_DHE_RSA_AES128_SHA256 :: Cipher cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1 { cipherID = 0x0067 , cipherName = "DHE-RSA-AES128-SHA256" , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherMinVer = Just TLS12 } cipher_DHE_RSA_AES256_SHA256 :: Cipher cipher_DHE_RSA_AES256_SHA256 = cipher_DHE_RSA_AES128_SHA256 { cipherID = 0x006B , cipherName = "DHE-RSA-AES256-SHA256" , cipherBulk = bulk_aes256 } -- | AESCCM cipher (128 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES128CCM_SHA256 :: Cipher cipher_AES128CCM_SHA256 = Cipher { cipherID = 0xc09c , cipherName = "RSA-AES128CCM-SHA256" , cipherBulk = bulk_aes128ccm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } -- | AESCCM8 cipher (128 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES128CCM8_SHA256 :: Cipher cipher_AES128CCM8_SHA256 = Cipher { cipherID = 0xc0a0 , cipherName = "RSA-AES128CCM8-SHA256" , cipherBulk = bulk_aes128ccm8 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } -- | AESGCM cipher (128 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES128GCM_SHA256 :: Cipher cipher_AES128GCM_SHA256 = Cipher { cipherID = 0x009C , cipherName = "RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } -- | AESCCM cipher (256 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES256CCM_SHA256 :: Cipher cipher_AES256CCM_SHA256 = Cipher { cipherID = 0xc09d , cipherName = "RSA-AES256CCM-SHA256" , cipherBulk = bulk_aes256ccm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } -- | AESCCM8 cipher (256 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES256CCM8_SHA256 :: Cipher cipher_AES256CCM8_SHA256 = Cipher { cipherID = 0xc0a1 , cipherName = "RSA-AES256CCM8-SHA256" , cipherBulk = bulk_aes256ccm8 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } -- | AESGCM cipher (256 bit key), RSA key exchange. -- The SHA384 digest is used as a PRF, not as a MAC. cipher_AES256GCM_SHA384 :: Cipher cipher_AES256GCM_SHA384 = Cipher { cipherID = 0x009D , cipherName = "RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } cipher_DHE_RSA_AES128CCM_SHA256 :: Cipher cipher_DHE_RSA_AES128CCM_SHA256 = Cipher { cipherID = 0xc09e , cipherName = "DHE-RSA-AES128CCM-SHA256" , cipherBulk = bulk_aes128ccm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } cipher_DHE_RSA_AES128CCM8_SHA256 :: Cipher cipher_DHE_RSA_AES128CCM8_SHA256 = Cipher { cipherID = 0xc0a2 , cipherName = "DHE-RSA-AES128CCM8-SHA256" , cipherBulk = bulk_aes128ccm8 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher cipher_DHE_RSA_AES128GCM_SHA256 = Cipher { cipherID = 0x009E , cipherName = "DHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_DHE_RSA_AES256CCM_SHA256 :: Cipher cipher_DHE_RSA_AES256CCM_SHA256 = Cipher { cipherID = 0xc09f , cipherName = "DHE-RSA-AES256CCM-SHA256" , cipherBulk = bulk_aes256ccm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } cipher_DHE_RSA_AES256CCM8_SHA256 :: Cipher cipher_DHE_RSA_AES256CCM8_SHA256 = Cipher { cipherID = 0xc0a3 , cipherName = "DHE-RSA-AES256CCM8-SHA256" , cipherBulk = bulk_aes256ccm8 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 } cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher cipher_DHE_RSA_AES256GCM_SHA384 = Cipher { cipherID = 0x009F , cipherName = "DHE-RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 } cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = Cipher { cipherID = 0xCCA8 , cipherName = "ECDHE-RSA-CHACHA20POLY1305-SHA256" , cipherBulk = bulk_chacha20poly1305 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 } cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = Cipher { cipherID = 0xCCA9 , cipherName = "ECDHE-ECDSA-CHACHA20POLY1305-SHA256" , cipherBulk = bulk_chacha20poly1305 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 } cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = Cipher { cipherID = 0xCCAA , cipherName = "DHE-RSA-CHACHA20POLY1305-SHA256" , cipherBulk = bulk_chacha20poly1305 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 } cipher_TLS13_AES128GCM_SHA256 :: Cipher cipher_TLS13_AES128GCM_SHA256 = Cipher { cipherID = 0x1301 , cipherName = "AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm_13 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13 , cipherMinVer = Just TLS13 } cipher_TLS13_AES256GCM_SHA384 :: Cipher cipher_TLS13_AES256GCM_SHA384 = Cipher { cipherID = 0x1302 , cipherName = "AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm_13 , cipherHash = SHA384 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13 , cipherMinVer = Just TLS13 } cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher cipher_TLS13_CHACHA20POLY1305_SHA256 = Cipher { cipherID = 0x1303 , cipherName = "CHACHA20POLY1305-SHA256" , cipherBulk = bulk_chacha20poly1305 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13 , cipherMinVer = Just TLS13 } cipher_TLS13_AES128CCM_SHA256 :: Cipher cipher_TLS13_AES128CCM_SHA256 = Cipher { cipherID = 0x1304 , cipherName = "AES128CCM-SHA256" , cipherBulk = bulk_aes128ccm_13 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13 , cipherMinVer = Just TLS13 } cipher_TLS13_AES128CCM8_SHA256 :: Cipher cipher_TLS13_AES128CCM8_SHA256 = Cipher { cipherID = 0x1305 , cipherName = "AES128CCM8-SHA256" , cipherBulk = bulk_aes128ccm8_13 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13 , cipherMinVer = Just TLS13 } cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher { cipherID = 0xC009 , cipherName = "ECDHE-ECDSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS10 } cipher_ECDHE_ECDSA_AES256CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES256CBC_SHA = Cipher { cipherID = 0xC00A , cipherName = "ECDHE-ECDSA-AES256CBC-SHA" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS10 } cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA = Cipher { cipherID = 0xC013 , cipherName = "ECDHE-RSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS10 } cipher_ECDHE_RSA_AES256CBC_SHA :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA = Cipher { cipherID = 0xC014 , cipherName = "ECDHE-RSA-AES256CBC-SHA" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS10 } cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA256 = Cipher { cipherID = 0xC027 , cipherName = "ECDHE-RSA-AES128CBC-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA384 = Cipher { cipherID = 0xC028 , cipherName = "ECDHE-RSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA256 = Cipher { cipherID = 0xc023 , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_ECDSA_AES256CBC_SHA384 = Cipher { cipherID = 0xC024 , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128CCM_SHA256 = Cipher { cipherID = 0xc0ac , cipherName = "ECDHE-ECDSA-AES128CCM-SHA256" , cipherBulk = bulk_aes128ccm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 7251 } cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = Cipher { cipherID = 0xc0ae , cipherName = "ECDHE-ECDSA-AES128CCM8-SHA256" , cipherBulk = bulk_aes128ccm8 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 7251 } cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher { cipherID = 0xC02B , cipherName = "ECDHE-ECDSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES256CCM_SHA256 = Cipher { cipherID = 0xc0ad , cipherName = "ECDHE-ECDSA-AES256CCM-SHA256" , cipherBulk = bulk_aes256ccm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 7251 } cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = Cipher { cipherID = 0xc0af , cipherName = "ECDHE-ECDSA-AES256CCM8-SHA256" , cipherBulk = bulk_aes256ccm8 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 7251 } cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher cipher_ECDHE_ECDSA_AES256GCM_SHA384 = Cipher { cipherID = 0xC02C , cipherName = "ECDHE-ECDSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_RSA_AES128GCM_SHA256 = Cipher { cipherID = 0xC02F , cipherName = "ECDHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher cipher_ECDHE_RSA_AES256GCM_SHA384 = Cipher { cipherID = 0xC030 , cipherName = "ECDHE-RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5289 } -- A list of cipher suite is found from: -- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 tls-1.5.4/Network/TLS/Extra/FFDHE.hs0000644000000000000000000001654613623162342015055 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-1.5.4/Tests/0000755000000000000000000000000013623162342011615 5ustar0000000000000000tls-1.5.4/Tests/PipeChan.hs0000644000000000000000000000440613623162342013644 0ustar0000000000000000-- create a similar concept than a unix pipe. module PipeChan ( PipeChan(..) , newPipe , runPipe , readPipeA , readPipeB , writePipeA , writePipeB ) where import Control.Applicative import Control.Concurrent.Chan import Control.Concurrent import Control.Monad (forever) import Data.ByteString (ByteString) import Data.IORef import qualified Data.ByteString as B -- | represent a unidirectional pipe with a buffered read channel and a write channel data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) newUniPipeChan :: IO UniPipeChan newUniPipeChan = UniPipeChan <$> newChan <*> newChan runUniPipe :: UniPipeChan -> IO ThreadId runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w getReadUniPipe :: UniPipeChan -> Chan ByteString getReadUniPipe (UniPipeChan r _) = r getWriteUniPipe :: UniPipeChan -> Chan ByteString getWriteUniPipe (UniPipeChan _ w) = w -- | Represent a bidirectional pipe with 2 nodes A and B data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan newPipe :: IO PipeChan newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan runPipe :: PipeChan -> IO ThreadId runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC readPipeA :: PipeChan -> Int -> IO ByteString readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz writePipeA :: PipeChan -> ByteString -> IO () writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c readPipeB :: PipeChan -> Int -> IO ByteString readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz writePipeB :: PipeChan -> ByteString -> IO () writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s -- helper to read buffered data. readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString readBuffered buf chan sz = do left <- readIORef buf if B.length left >= sz then do let (ret, nleft) = B.splitAt sz left writeIORef buf nleft return ret else do let newSize = (sz - B.length left) newData <- readChan chan writeIORef buf newData remain <- readBuffered buf chan newSize return (left `B.append` remain) tls-1.5.4/Tests/Connection.hs0000644000000000000000000004440013623162342014252 0ustar0000000000000000-- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Connection ( newPairContext , arbitraryCiphers , arbitraryVersions , arbitraryHashSignatures , arbitraryGroups , arbitraryKeyUsage , arbitraryPairParams , arbitraryPairParams13 , arbitraryPairParamsWithVersionsAndCiphers , arbitraryClientCredential , arbitraryCredentialsOfEachCurve , arbitraryRSACredentialWithUsage , dhParamsGroup , getConnectVersion , isVersionEnabled , isCustomDHParams , isLeafRSA , isCredentialDSA , arbitraryEMSMode , setEMSMode , readClientSessionRef , twoSessionRefs , twoSessionManagers , setPairParamsSessionManagers , setPairParamsSessionResuming , withDataPipe , initiateDataPipe , byeBye ) where import Test.Tasty.QuickCheck import Certificate import PubKey import PipeChan import Network.TLS as TLS import Network.TLS.Extra import Data.X509 import Data.Default.Class import Data.IORef import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.Chan import Control.Concurrent import qualified Control.Exception as E import Control.Monad (unless, when) import Data.List (intersect, isInfixOf) import qualified Data.ByteString as B debug :: Bool debug = False knownCiphers :: [Cipher] knownCiphers = ciphersuite_all ++ ciphersuite_weak where ciphersuite_weak = [ cipher_DHE_DSS_RC4_SHA1 , cipher_RC4_128_MD5 , cipher_null_MD5 , cipher_null_SHA1 ] -- local restriction: EdDSA credentials are not usable before TLS12 so without -- ECDSA support it is not possible for ECDHE_ECDSA to be successful with TLS10 -- and TLS11 cipherAllowedForVersion' :: Version -> Cipher -> Bool cipherAllowedForVersion' connectVersion x = cipherAllowedForVersion connectVersion x && (connectVersion >= TLS12 || cipherKeyExchange x /= CipherKeyExchange_ECDHE_ECDSA) arbitraryCiphers :: Gen [Cipher] arbitraryCiphers = listOf1 $ elements knownCiphers knownVersions :: [Version] knownVersions = [TLS13,TLS12,TLS11,TLS10,SSL3] arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions knownHashSignatures :: [HashAndSignatureAlgorithm] knownHashSignatures = filter nonECDSA availableHashSignatures where availableHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssRSAeSHA512) ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA384) ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA256) ,(TLS.HashIntrinsic, SignatureEd25519) ,(TLS.HashIntrinsic, SignatureEd448) ,(TLS.HashSHA512, SignatureRSA) ,(TLS.HashSHA512, SignatureECDSA) ,(TLS.HashSHA384, SignatureRSA) ,(TLS.HashSHA384, SignatureECDSA) ,(TLS.HashSHA256, SignatureRSA) ,(TLS.HashSHA256, SignatureECDSA) ,(TLS.HashSHA1, SignatureRSA) ,(TLS.HashSHA1, SignatureDSS) ] -- arbitraryCredentialsOfEachType cannot generate ECDSA nonECDSA (_,s) = s /= SignatureECDSA knownHashSignatures13 :: [HashAndSignatureAlgorithm] knownHashSignatures13 = filter compat knownHashSignatures where compat (h,s) = h /= TLS.HashSHA1 && s /= SignatureDSS && s /= SignatureRSA arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm] arbitraryHashSignatures v = sublistOf l where l = if v < TLS13 then knownHashSignatures else knownHashSignatures13 -- for performance reason P521, FFDHE6144, FFDHE8192 are not tested knownGroups, knownECGroups, knownFFGroups :: [Group] knownECGroups = [P256,P384,X25519,X448] knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096] knownGroups = knownECGroups ++ knownFFGroups arbitraryGroups :: Gen [Group] arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups isCredentialDSA :: (CertificateChain, PrivKey) -> Bool isCredentialDSA (_, PrivKeyDSA _) = True isCredentialDSA _ = False arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType = do let (pubKey, privKey) = getGlobalRSAPair (dsaPub, dsaPriv) <- arbitraryDSAPair (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair (ed448Pub, ed448Priv) <- arbitraryEd448Pair mapM (\(pub, priv) -> do cert <- arbitraryX509WithKey (pub, priv) return (CertificateChain [cert], priv) ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey) , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) ] arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachCurve = do (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) ] dhParamsGroup :: DHParams -> Maybe Group dhParamsGroup params | params == ffdhe2048 = Just FFDHE2048 | params == ffdhe3072 = Just FFDHE3072 | otherwise = Nothing isCustomDHParams :: DHParams -> Bool isCustomDHParams params = params == dhParams512 leafPublicKey :: CertificateChain -> Maybe PubKey leafPublicKey (CertificateChain []) = Nothing leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ getCertificate leaf) isLeafRSA :: Maybe CertificateChain -> Bool isLeafRSA chain = case chain >>= leafPublicKey of Just (PubKeyRSA _) -> True _ -> False arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` (\cs -> or [cipherAllowedForVersion' connectVersion x | x <- cs]) clientCiphers <- arbitraryCiphers `suchThat` (\cs -> or [x `elem` serverCiphers && cipherAllowedForVersion' connectVersion x | x <- cs]) return (clientCiphers, serverCiphers) arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt -- pair of groups so that at least one EC and one FF group are in common arbitraryGroupPair :: Gen ([Group], [Group]) arbitraryGroupPair = do (serverECGroups, clientECGroups) <- arbitraryGroupPairFrom knownECGroups (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups serverGroups <- shuffle (serverECGroups ++ serverFFGroups) clientGroups <- shuffle (clientECGroups ++ clientFFGroups) return (clientGroups, serverGroups) where arbitraryGroupPairFrom list = do s <- arbitraryGroupsFrom list c <- arbitraryGroupsFrom list `suchThat` any (`elem` s) return (c, s) arbitraryGroupsFrom list = listOf1 $ elements list arbitraryPairParams13 :: Gen (ClientParams, ServerParams) arbitraryPairParams13 = arbitraryPairParamsAt TLS13 arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams) arbitraryPairParamsAt connectVersion = do (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion -- Select version lists containing connectVersion, as well as some other -- versions for which we have compatible ciphers. Criteria about cipher -- ensure we can test version downgrade. let allowedVersions = [ v | v <- knownVersions, or [ x `elem` serverCiphers && cipherAllowedForVersion' v x | x <- clientCiphers ]] allowedVersionsFiltered = filter (<= connectVersion) allowedVersions -- Server or client is allowed to have versions > connectVersion, but not -- both simultaneously. filterSrv <- arbitrary let (clientAllowedVersions, serverAllowedVersions) | filterSrv = (allowedVersions, allowedVersionsFiltered) | otherwise = (allowedVersionsFiltered, allowedVersions) -- Generate version lists containing less than 127 elements, otherwise the -- "supported_versions" extension cannot be correctly serialized clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) where listWithOthers :: a -> Int -> [a] -> Gen [a] listWithOthers fixedElement maxOthers others | maxOthers < 1 = return [fixedElement] | otherwise = sized $ \n -> do num <- choose (0, min n maxOthers) pos <- choose (0, num) prefix <- vectorOf pos $ elements others suffix <- vectorOf (num - pos) $ elements others return $ prefix ++ (fixedElement : suffix) getConnectVersion :: (ClientParams, ServerParams) -> Version getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) where sver = supportedVersions (serverSupported sparams) cver = supportedVersions (clientSupported cparams) isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool isVersionEnabled ver (cparams, sparams) = (ver `elem` supportedVersions (serverSupported sparams)) && (ver `elem` supportedVersions (clientSupported cparams)) arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) arbitraryHashSignaturePair = do serverHashSignatures <- shuffle knownHashSignatures clientHashSignatures <- shuffle knownHashSignatures return (clientHashSignatures, serverHashSignatures) arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version]) -> ([Cipher], [Cipher]) -> Gen (ClientParams, ServerParams) arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do secNeg <- arbitrary dhparams <- elements [dhParams512,ffdhe2048,ffdhe3072] creds <- arbitraryCredentialsOfEachType (clientGroups, serverGroups) <- arbitraryGroupPair (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def { serverSupported = def { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures } , serverDHEParams = Just dhparams , serverShared = def { sharedCredentials = Credentials creds } } let clientState = (defaultParamsClient "" B.empty) { clientSupported = def { supportedCiphers = clientCiphers , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg , supportedGroups = clientGroups , supportedHashSignatures = clientHashSignatures } , clientShared = def { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () , cacheQuery = \_ _ _ -> return ValidationCachePass } } } return (clientState, serverState) arbitraryClientCredential :: Version -> Gen Credential arbitraryClientCredential SSL3 = do -- for SSL3 there is no EC but only RSA/DSA creds <- arbitraryCredentialsOfEachType elements (take 2 creds) -- RSA and DSA, but not Ed25519 and Ed448 arbitraryClientCredential v | v < TLS12 = do -- for TLS10 and TLS11 there is no EdDSA but only RSA/DSA/ECDSA creds <- arbitraryCredentialsOfEachType elements (take 2 creds) -- RSA and DSA (ECDSA later), but not EdDSA arbitraryClientCredential _ = arbitraryCredentialsOfEachType >>= elements arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) arbitraryRSACredentialWithUsage usageFlags = do let (pubKey, privKey) = getGlobalRSAPair cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) return (CertificateChain [cert], PrivKeyRSA privKey) arbitraryEMSMode :: Gen (EMSMode, EMSMode) arbitraryEMSMode = (,) <$> gen <*> gen where gen = elements [ NoEMS, AllowEMS, RequireEMS ] setEMSMode :: (EMSMode, EMSMode) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam') where clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedExtendedMasterSec = cems } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedExtendedMasterSec = sems } } readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient readClientSessionRef refs = readIORef (fst refs) twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server)) twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing -- | simple session manager to store one session id and session data for a single thread. -- a Real concurrent session manager would use an MVar and have multiples items. oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager oneSessionManager ref = SessionManager { sessionResume = \myId -> readIORef ref >>= maybeResume False myId , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) , sessionInvalidate = \_ -> return () } where maybeResume onlyOnce myId (Just (sid, sdata)) | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata) maybeResume _ _ _ = return Nothing twoSessionManagers :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) -> (SessionManager, SessionManager) twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef) setPairParamsSessionManagers :: (SessionManager, SessionManager) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionManagers (clientManager, serverManager) (clientState, serverState) = (nc,ns) where nc = clientState { clientShared = updateSessionManager clientManager $ clientShared clientState } ns = serverState { serverShared = updateSessionManager serverManager $ serverShared serverState } updateSessionManager manager shared = shared { sharedSessionManager = manager } setPairParamsSessionResuming :: (SessionID, SessionData) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionResuming sessionStuff (clientState, serverState) = ( clientState { clientWantSessionResume = Just sessionStuff } , serverState) newPairContext :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) newPairContext pipe (cParams, sParams) = do let noFlush = return () let noClose = return () let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe) let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe) cCtx' <- contextNew cBackend cParams sCtx' <- contextNew sBackend sParams contextHookSetLogging cCtx' (logging "client: ") contextHookSetLogging sCtx' (logging "server: ") return (cCtx', sCtx') where logging pre = if debug then def { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } else def withDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> ((start -> IO (), IO result) -> IO a) -> IO a withDataPipe params tlsServer tlsClient cont = do -- initial setup pipe <- newPipe _ <- runPipe pipe startQueue <- newChan resultQueue <- newChan (cCtx, sCtx) <- newPairContext pipe params withAsync (E.catch (tlsServer sCtx resultQueue) (printAndRaise "server" (serverSupported $ snd params))) $ \sAsync -> do withAsync (E.catch (tlsClient startQueue cCtx) (printAndRaise "client" (clientSupported $ fst params))) $ \cAsync -> do let readResult = waitBoth cAsync sAsync >> readChan resultQueue cont (writeChan startQueue, readResult) where printAndRaise :: String -> Supported -> E.SomeException -> IO () printAndRaise s supported e = do putStrLn $ s ++ " exception: " ++ show e ++ ", supported: " ++ show supported E.throwIO e initiateDataPipe :: (ClientParams, ServerParams) -> (Context -> IO a1) -> (Context -> IO a) -> IO (Either E.SomeException a, Either E.SomeException a1) initiateDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe _ <- runPipe pipe (cCtx, sCtx) <- newPairContext pipe params async (tlsServer sCtx) >>= \sAsync -> async (tlsClient cCtx) >>= \cAsync -> do sRes <- waitCatch sAsync cRes <- waitCatch cAsync return (cRes, sRes) -- Terminate the write direction and wait to receive the peer EOF. This is -- necessary in situations where we want to confirm the peer status, or to make -- sure to receive late messages like session tickets. In the test suite this -- is used each time application code ends the connection without prior call to -- 'recvData'. byeBye :: Context -> IO () byeBye ctx = do bye ctx bs <- recvData ctx unless (B.null bs) $ fail "byeBye: unexpected application data" tls-1.5.4/Tests/Tests.hs0000644000000000000000000012332113623162342013255 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import Test.Tasty import Test.Tasty.QuickCheck import Test.QuickCheck.Monadic import PipeChan import Connection import Marshalling import Ciphers import PubKey import Data.Foldable (traverse_) import Data.Maybe import Data.Default.Class import Data.List (intersect) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Network.TLS import Network.TLS.Extra import Network.TLS.Internal import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Data.IORef import Data.X509 (ExtKeyUsageFlag(..)) import System.Timeout prop_pipe_work :: PropertyM IO () prop_pipe_work = do pipe <- run newPipe _ <- run (runPipe pipe) let bSize = 16 n <- pick (choose (1, 32)) let d1 = B.replicate (bSize * n) 40 let d2 = B.replicate (bSize * n) 45 d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) d1 `assertEq` d1' d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) d2 `assertEq` d2' return () chunkLengths :: Int -> [Int] chunkLengths len | len > 16384 = 16384 : chunkLengths (len - 16384) | len > 0 = [len] | otherwise = [] runTLSPipeN :: Int -> (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () runTLSPipeN n params tlsServer tlsClient = do -- generate some data to send ds <- replicateM n $ do d <- B.pack <$> pick (someWords8 256) return d -- send it m_dsres <- run $ do withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do forM_ ds $ \d -> do writeStart d -- receive it timeout 60000000 readResult -- 60 sec case m_dsres of Nothing -> error "timed out" Just dsres -> ds `assertEq` dsres runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () runTLSPipe = runTLSPipeN 1 runTLSPipePredicate :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO () runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx checkInfoPredicate ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do handshake ctx checkInfoPredicate ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx checkInfoPredicate ctx = do minfo <- contextGetInformation ctx unless (p minfo) $ fail ("unexpected information: " ++ show minfo) runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO () runTLSPipeSimple params = runTLSPipePredicate params (const True) runTLSPipeSimple13 :: (ClientParams, ServerParams) -> HandshakeMode13 -> Maybe C8.ByteString -> PropertyM IO () runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx case mEarlyData of Nothing -> return () Just ed -> do let ls = chunkLengths (B.length ed) chunks <- replicateM (length ls) $ recvData ctx (ls, ed) `assertEq` (map B.length chunks, B.concat chunks) d <- recvData ctx writeChan queue [d] minfo <- contextGetInformation ctx Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) bye ctx tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) minfo <- contextGetInformation ctx Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) byeBye ctx runTLSPipeCapture13 :: (ClientParams, ServerParams) -> PropertyM IO ([Handshake13], [Handshake13]) runTLSPipeCapture13 params = do sRef <- run $ newIORef [] cRef <- run $ newIORef [] runTLSPipe params (tlsServer sRef) (tlsClient cRef) sReceived <- run $ readIORef sRef cReceived <- run $ readIORef cRef return (reverse sReceived, reverse cReceived) where tlsServer ref ctx queue = do installHook ctx ref handshake ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient ref queue ctx = do installHook ctx ref handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx installHook ctx ref = let recv hss = modifyIORef ref (hss :) >> return hss in contextHookSetHandshake13Recv ctx recv runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO () runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx d0 <- recvData ctx req <- generate $ elements [OneWay, TwoWay] _ <- updateKey ctx req d1 <- recvData ctx d2 <- recvData ctx writeChan queue [d0,d1,d2] bye ctx tlsClient queue ctx = do handshake ctx d0 <- readChan queue sendData ctx (L.fromChunks [d0]) d1 <- readChan queue sendData ctx (L.fromChunks [d1]) req <- generate $ elements [OneWay, TwoWay] _ <- updateKey ctx req d2 <- readChan queue sendData ctx (L.fromChunks [d2]) byeBye ctx runTLSInitFailureGen :: (ClientParams, ServerParams) -> (Context -> IO s) -> (Context -> IO c) -> PropertyM IO () runTLSInitFailureGen params hsServer hsClient = do (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient) assertIsLeft cRes assertIsLeft sRes where tlsServer ctx = do _ <- hsServer ctx minfo <- contextGetInformation ctx byeBye ctx return $ "server success: " ++ show minfo tlsClient ctx = do _ <- hsClient ctx minfo <- contextGetInformation ctx byeBye ctx return $ "client success: " ++ show minfo runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO () runTLSInitFailure params = runTLSInitFailureGen params handshake handshake prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do params <- pick arbitraryPairParams runTLSPipeSimple params prop_handshake13_initiate :: PropertyM IO () prop_handshake13_initiate = do params <- pick arbitraryPairParams13 let cgrps = supportedGroups $ clientSupported $ fst params sgrps = supportedGroups $ serverSupported $ snd params hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest runTLSPipeSimple13 params hs Nothing prop_handshake_keyupdate :: PropertyM IO () prop_handshake_keyupdate = do params <- pick arbitraryPairParams runTLSPipeSimpleKeyUpdate params prop_handshake13_downgrade :: PropertyM IO () prop_handshake13_downgrade = do (cparam,sparam) <- pick arbitraryPairParams versionForced <- pick $ elements (supportedVersions $ clientSupported cparam) let debug' = (serverDebug sparam) { debugVersionForced = Just versionForced } sparam' = sparam { serverDebug = debug' } params = (cparam,sparam') downgraded = (isVersionEnabled TLS13 params && versionForced < TLS13) || (isVersionEnabled TLS12 params && versionForced < TLS12) if downgraded then runTLSInitFailure params else runTLSPipeSimple params prop_handshake13_full :: PropertyM IO () prop_handshake13_full = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported } ) runTLSPipeSimple13 params FullHandshake Nothing prop_handshake13_hrr :: PropertyM IO () prop_handshake13_hrr = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported } ) runTLSPipeSimple13 params HelloRetryRequest Nothing prop_handshake13_psk :: PropertyM IO () prop_handshake13_psk = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params0 = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported } ) sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSPipeSimple13 params HelloRetryRequest Nothing -- and resume sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPipeSimple13 params2 PreSharedKey Nothing prop_handshake13_psk_fallback :: PropertyM IO () prop_handshake13_psk_fallback = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def { supportedCiphers = [ cipher_TLS13_AES128GCM_SHA256 , cipher_TLS13_AES128CCM_SHA256 ] , supportedGroups = [P256,X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params0 = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported } ) sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSPipeSimple13 params HelloRetryRequest Nothing -- resumption fails because GCM cipher is not supported anymore, full -- handshake is not possible because X25519 has been removed, so we are -- back with P256 after hello retry sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params srv2' = srv2 { serverSupported = svrSupported' } svrSupported' = def { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] , supportedGroups = [P256] } runTLSPipeSimple13 (cli2, srv2') HelloRetryRequest Nothing prop_handshake13_rtt0 :: PropertyM IO () prop_handshake13_rtt0 = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } cliHooks = def { onSuggestALPN = return $ Just ["h2"] } svrHooks = def { onALPNClientSuggest = Just (\protos -> return $ head protos) } params0 = (cli { clientSupported = cliSupported , clientHooks = cliHooks } ,srv { serverSupported = svrSupported , serverHooks = svrHooks , serverEarlyDataSize = 2048 } ) sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSPipeSimple13 params HelloRetryRequest Nothing -- and resume sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) earlyData <- B.pack <$> pick (someWords8 256) let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params params2 = (pc { clientEarlyData = Just earlyData } , ps) runTLSPipeSimple13 params2 RTT0 (Just earlyData) prop_handshake13_rtt0_fallback :: PropertyM IO () prop_handshake13_rtt0_fallback = do ticketSize <- pick $ choose (0, 512) (cli, srv) <- pick arbitraryPairParams13 group0 <- pick $ elements [P256,X25519] let cliSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [P256,X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [group0] } params0 = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported , serverEarlyDataSize = ticketSize } ) sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 let mode = if group0 == P256 then FullHandshake else HelloRetryRequest runTLSPipeSimple13 params mode Nothing -- and resume sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) earlyData <- B.pack <$> pick (someWords8 256) group2 <- pick $ elements [P256,X25519] let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params svrSupported2 = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [group2] } params2 = (pc { clientEarlyData = Just earlyData } ,ps { serverEarlyDataSize = 0 , serverSupported = svrSupported2 } ) let mode2 = if ticketSize < 256 then PreSharedKey else RTT0 runTLSPipeSimple13 params2 mode2 Nothing prop_handshake13_rtt0_length :: PropertyM IO () prop_handshake13_rtt0_length = do serverMax <- pick $ choose (0, 33792) (cli, srv) <- pick arbitraryPairParams13 let cliSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } svrSupported = def { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] , supportedGroups = [X25519] } params0 = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported , serverEarlyDataSize = serverMax } ) sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs let params = setPairParamsSessionManagers sessionManagers params0 runTLSPipeSimple13 params FullHandshake Nothing -- and resume sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) clientLen <- pick $ choose (0, 33792) earlyData <- B.pack <$> pick (someWords8 clientLen) let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params params2 = (pc { clientEarlyData = Just earlyData } , ps) (mode, mEarlyData) | clientLen > serverMax = (PreSharedKey, Nothing) | otherwise = (RTT0, Just earlyData) runTLSPipeSimple13 params2 mode mEarlyData prop_handshake13_ee_groups :: PropertyM IO () prop_handshake13_ee_groups = do (cli, srv) <- pick arbitraryPairParams13 let cliSupported = (clientSupported cli) { supportedGroups = [P256,X25519] } svrSupported = (serverSupported srv) { supportedGroups = [X25519,P256] } params = (cli { clientSupported = cliSupported } ,srv { serverSupported = svrSupported } ) (_, serverMessages) <- runTLSPipeCapture13 params let isNegotiatedGroups (ExtensionRaw eid _) = eid == 0xa eeMessagesHaveExt = [ any isNegotiatedGroups exts | EncryptedExtensions13 exts <- serverMessages ] [True] `assertEq` eeMessagesHaveExt -- one EE message with extension prop_handshake_ciphersuites :: PropertyM IO () prop_handshake_ciphersuites = do tls13 <- pick arbitrary let version = if tls13 then TLS13 else TLS12 clientCiphers <- pick arbitraryCiphers serverCiphers <- pick arbitraryCiphers (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers ([version], [version]) (clientCiphers, serverCiphers) let adequate = cipherAllowedForVersion version shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) if shouldSucceed then runTLSPipeSimple (clientParam,serverParam) else runTLSInitFailure (clientParam,serverParam) prop_handshake_hashsignatures :: PropertyM IO () prop_handshake_hashsignatures = do tls13 <- pick arbitrary let version = if tls13 then TLS13 else TLS12 ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_ECDSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_ECDHE_ECDSA_AES128CBC_SHA , cipher_DHE_RSA_AES128_SHA1 , cipher_DHE_DSS_AES128_SHA1 , cipher_TLS13_AES128GCM_SHA256 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers ([version], [version]) (ciphers, ciphers) clientHashSigs <- pick $ arbitraryHashSignatures version serverHashSigs <- pick $ arbitraryHashSignatures version let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = clientHashSigs } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedHashSignatures = serverHashSigs } } shouldFail = null (clientHashSigs `intersect` serverHashSigs) if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (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_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA -- certificate. prop_handshake_cert_fallback :: PropertyM IO () prop_handshake_cert_fallback = do let clientVersions = [TLS12] serverVersions = [TLS12] commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ] otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_DHE_DSS_AES128_SHA1 ] hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ] chainRef <- run $ newIORef Nothing clientCiphers <- pick $ sublistOf otherCiphers serverCiphers <- pick $ sublistOf otherCiphers (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = hashSignatures } , clientHooks = (clientHooks clientParam) { onServerCertificate = \_ _ _ chain -> writeIORef chainRef (Just chain) >> return [] } } dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers runTLSPipeSimple (clientParam',serverParam) serverChain <- run $ readIORef chainRef dssDisallowed `assertEq` isLeafRSA serverChain -- Same as above but testing with supportedHashSignatures directly instead of -- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the -- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by -- both client and server, the Ed25519 certificate is selected. Otherwise the -- server fallbacks to RSA. -- -- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 -- unless client advertises explicit support. Currently this is not enforced by -- the library, which is useful to test this scenario. SHA-1 could be replaced -- by another algorithm. prop_handshake_cert_fallback_hs :: PropertyM IO () prop_handshake_cert_fallback_hs = do tls13 <- pick arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = [ cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_TLS13_AES128GCM_SHA256 ] commonHS = [ (HashSHA256, SignatureRSA) , (HashIntrinsic, SignatureRSApssRSAeSHA256) ] otherHS = [ (HashIntrinsic, SignatureEd25519) ] chainRef <- run $ newIORef Nothing clientHS <- pick $ sublistOf otherHS serverHS <- pick $ sublistOf otherHS (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = commonHS ++ clientHS } , clientHooks = (clientHooks clientParam) { onServerCertificate = \_ _ _ chain -> writeIORef chainRef (Just chain) >> return [] } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedHashSignatures = commonHS ++ serverHS } } eddsaDisallowed = (HashIntrinsic, SignatureEd25519) `notElem` clientHS || (HashIntrinsic, SignatureEd25519) `notElem` serverHS runTLSPipeSimple (clientParam',serverParam') serverChain <- run $ readIORef chainRef eddsaDisallowed `assertEq` isLeafRSA serverChain prop_handshake_groups :: PropertyM IO () prop_handshake_groups = do tls13 <- pick arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_DHE_RSA_AES256GCM_SHA384 , cipher_DHE_RSA_AES128_SHA1 , cipher_TLS13_AES128GCM_SHA256 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) clientGroups <- pick arbitraryGroups serverGroups <- pick arbitraryGroups denyCustom <- pick arbitrary let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = clientGroups } , clientHooks = (clientHooks clientParam) { onCustomFFDHEGroup = \_ _ -> return groupUsage } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups } } isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup commonGroups = clientGroups `intersect` serverGroups shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom) p minfo = isNothing (minfo >>= infoNegotiatedGroup) == (null commonGroups && isCustom) if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipePredicate (clientParam',serverParam') p prop_handshake_dh :: PropertyM IO () prop_handshake_dh = do let clientVersions = [TLS12] serverVersions = [TLS12] ciphers = [ cipher_DHE_RSA_AES128_SHA1 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (ciphers, ciphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = [] } } let check (dh,shouldFail) = do let serverParam' = serverParam { serverDHEParams = Just dh } if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam') mapM_ check [(dhParams512,True) ,(dhParams768,True) ,(dhParams1024,False)] prop_handshake_srv_key_usage :: PropertyM IO () prop_handshake_srv_key_usage = do tls13 <- pick arbitrary let versions = if tls13 then [TLS13] else [TLS12,TLS11,TLS10,SSL3] ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA , cipher_TLS13_AES128GCM_SHA256 , cipher_DHE_RSA_AES128_SHA1 , cipher_AES256_SHA256 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (versions, versions) (ciphers, ciphers) usageFlags <- pick arbitraryKeyUsage cred <- pick $ arbitraryRSACredentialWithUsage usageFlags let serverParam' = serverParam { serverShared = (serverShared serverParam) { sharedCredentials = Credentials [cred] } } hasDS = KeyUsage_digitalSignature `elem` usageFlags hasKE = KeyUsage_keyEncipherment `elem` usageFlags shouldSucceed = hasDS || (hasKE && not tls13) if shouldSucceed then runTLSPipeSimple (clientParam,serverParam') else runTLSInitFailure (clientParam,serverParam') prop_handshake_client_auth :: PropertyM IO () prop_handshake_client_auth = do (clientParam,serverParam) <- pick arbitraryPairParams let clientVersions = supportedVersions $ clientSupported clientParam serverVersions = supportedVersions $ serverSupported serverParam version = maximum (clientVersions `intersect` serverVersions) cred <- pick (arbitraryClientCredential version) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverWantClientCert = True , serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } } let shouldFail = version == TLS13 && isCredentialDSA cred if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam') where validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) prop_post_handshake_auth :: PropertyM IO () prop_post_handshake_auth = do (clientParam,serverParam) <- pick arbitraryPairParams13 cred <- pick (arbitraryClientCredential TLS13) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } } if isCredentialDSA cred then runTLSInitFailureGen (clientParam',serverParam') hsServer hsClient else runTLSPipe (clientParam',serverParam') tlsServer tlsClient where validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) tlsServer ctx queue = do hsServer ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do hsClient ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx hsServer ctx = do handshake ctx recvDataAssert ctx "request 1" _ <- requestCertificate ctx -- single request sendData ctx "response 1" recvDataAssert ctx "request 2" _ <- requestCertificate ctx _ <- requestCertificate ctx -- two simultaneously sendData ctx "response 2" hsClient ctx = do handshake ctx sendData ctx "request 1" recvDataAssert ctx "response 1" sendData ctx "request 2" recvDataAssert ctx "response 2" prop_handshake_clt_key_usage :: PropertyM IO () prop_handshake_clt_key_usage = do (clientParam,serverParam) <- pick arbitraryPairParams usageFlags <- pick arbitraryKeyUsage cred <- pick $ arbitraryRSACredentialWithUsage usageFlags let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverWantClientCert = True , serverHooks = (serverHooks serverParam) { onClientCertificate = \_ -> return CertificateUsageAccept } } shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags if shouldSucceed then runTLSPipeSimple (clientParam',serverParam') else runTLSInitFailure (clientParam',serverParam') prop_handshake_ems :: PropertyM IO () prop_handshake_ems = do (cems, sems) <- pick arbitraryEMSMode params <- pick arbitraryPairParams let params' = setEMSMode (cems, sems) params version = getConnectVersion params' emsVersion = version >= TLS10 && version <= TLS12 use = cems /= NoEMS && sems /= NoEMS require = cems == RequireEMS || sems == RequireEMS p info = infoExtendedMasterSec info == (emsVersion && use) if emsVersion && require && not use then runTLSInitFailure params' else runTLSPipePredicate params' (maybe False p) prop_handshake_session_resumption_ems :: PropertyM IO () prop_handshake_session_resumption_ems = do sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs plainParams <- pick arbitraryPairParams ems <- pick (arbitraryEMSMode `suchThat` compatible) let params = setEMSMode ems $ setPairParamsSessionManagers sessionManagers plainParams runTLSPipeSimple params -- and resume sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) ems2 <- pick (arbitraryEMSMode `suchThat` compatible) let params2 = setEMSMode ems2 $ setPairParamsSessionResuming (fromJust sessionParams) params let version = getConnectVersion params2 emsVersion = version >= TLS10 && version <= TLS12 if emsVersion && use ems && not (use ems2) then runTLSInitFailure params2 else do runTLSPipeSimple params2 sessionParams2 <- run $ readClientSessionRef sessionRefs let sameSession = sessionParams == sessionParams2 sameUse = use ems == use ems2 when emsVersion $ assert (sameSession == sameUse) where compatible (NoEMS, RequireEMS) = False compatible (RequireEMS, NoEMS) = False compatible _ = True use (NoEMS, _) = False use (_, NoEMS) = False use _ = True prop_handshake_alpn :: PropertyM IO () prop_handshake_alpn = do (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onSuggestALPN = return $ Just ["h2", "http/1.1"] } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onALPNClientSuggest = Just alpn } } params' = (clientParam',serverParam') runTLSPipe params' tlsServer tlsClient where tlsServer ctx queue = do handshake ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do handshake ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx alpn xs | "h2" `elem` xs = return "h2" | otherwise = return "http/1.1" prop_handshake_sni :: PropertyM IO () prop_handshake_sni = do ref <- run $ newIORef Nothing (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientServerIdentification = (serverName, "") } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onServerNameIndication = onSNI ref } } params' = (clientParam',serverParam') runTLSPipe params' tlsServer tlsClient receivedName <- run $ readIORef ref Just (Just serverName) `assertEq` receivedName where tlsServer ctx queue = do handshake ctx sni <- getClientSNI ctx Just serverName `assertEq` sni d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do handshake ctx sni <- getClientSNI ctx Just serverName `assertEq` sni d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx onSNI ref name = assertEmptyRef ref >> writeIORef ref (Just name) >> return (Credentials []) serverName = "haskell.org" prop_handshake_renegotiation :: PropertyM IO () prop_handshake_renegotiation = do renegDisabled <- pick arbitrary (cparams, sparams) <- pick arbitraryPairParams let sparams' = sparams { serverSupported = (serverSupported sparams) { supportedClientInitiatedRenegotiation = not renegDisabled } } if renegDisabled || isVersionEnabled TLS13 (cparams, sparams') then runTLSInitFailureGen (cparams, sparams') hsServer hsClient else runTLSPipe (cparams, sparams') tlsServer tlsClient where tlsServer ctx queue = do hsServer ctx d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do hsClient ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx hsServer = handshake hsClient ctx = handshake ctx >> handshake ctx prop_handshake_session_resumption :: PropertyM IO () prop_handshake_session_resumption = do sessionRefs <- run twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs plainParams <- pick arbitraryPairParams let params = setPairParamsSessionManagers sessionManagers plainParams runTLSPipeSimple params -- and resume sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPipeSimple params2 prop_thread_safety :: PropertyM IO () prop_thread_safety = do params <- pick arbitraryPairParams runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx runReaderWriters ctx "client-value" "server-value" d <- recvData ctx writeChan queue [d] bye ctx tlsClient queue ctx = do handshake ctx runReaderWriters ctx "server-value" "client-value" d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx runReaderWriters ctx r w = -- run concurrently 10 readers and 10 writers on the same context let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] in runConcurrently $ traverse_ Concurrently workers assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) assertIsLeft :: (Show b, Monad m) => Either a b -> m () assertIsLeft (Left _) = return () assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") assertEmptyRef :: Show a => IORef (Maybe a) -> IO () assertEmptyRef ref = readIORef ref >>= maybe (return ()) (\a -> error ("got " ++ show a ++ " but was expecting empty reference")) recvDataAssert :: Context -> C8.ByteString -> IO () recvDataAssert ctx expected = do got <- recvData ctx assertEq expected got main :: IO () main = defaultMain $ testGroup "tls" [ tests_marshalling , tests_ciphers , tests_handshake , tests_thread_safety ] where -- lowlevel tests to check the packet marshalling. tests_marshalling = testGroup "Marshalling" [ testProperty "Header" prop_header_marshalling_id , testProperty "Handshake" prop_handshake_marshalling_id , testProperty "Handshake13" prop_handshake13_marshalling_id ] tests_ciphers = testGroup "Ciphers" [ testProperty "Bulk" propertyBulkFunctional ] -- high level tests between a client and server with fake ciphers. tests_handshake = testGroup "Handshakes" [ testProperty "Setup" (monadicIO prop_pipe_work) , testProperty "Initiation" (monadicIO prop_handshake_initiate) , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate) , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate) , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade) , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) , testProperty "Groups" (monadicIO prop_handshake_groups) , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback) , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs) , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage) , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage) , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems) , testProperty "Extended Master Secret (resumption)" (monadicIO prop_handshake_session_resumption_ems) , testProperty "ALPN" (monadicIO prop_handshake_alpn) , testProperty "SNI" (monadicIO prop_handshake_sni) , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) , testProperty "Custom DH" (monadicIO prop_handshake_dh) , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full) , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr) , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk) , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback) , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0) , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback) , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length) , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups) , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) ] -- test concurrent reads and writes tests_thread_safety = localOption (QuickCheckTests 10) $ testProperty "Thread safety" (monadicIO prop_thread_safety) tls-1.5.4/Tests/Ciphers.hs0000644000000000000000000000356113623162342013553 0ustar0000000000000000-- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Ciphers ( propertyBulkFunctional ) where import Control.Applicative ((<$>), (<*>)) import Test.Tasty.QuickCheck import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Extra.Cipher arbitraryKey :: Bulk -> Gen B.ByteString arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString deriving (Show,Eq) instance Arbitrary BulkTest where arbitrary = do bulk <- cipherBulk `fmap` elements ciphersuite_all BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk <*> arbitraryText bulk propertyBulkFunctional :: BulkTest -> Bool propertyBulkFunctional (BulkTest bulk key iv t additional) = let enc = bulkInit bulk BulkEncrypt key dec = bulkInit bulk BulkDecrypt key in case (enc, dec) of (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF _ -> True where block e d = let (etxt, e_iv) = e iv t (dtxt, d_iv) = d iv etxt in dtxt == t && d_iv == e_iv stream e d = (fst . d . fst . e) t == t aead e d = let (encrypted, at) = e iv t additional (decrypted, at2) = d iv encrypted additional in decrypted == t && at == at2 tls-1.5.4/Tests/Certificate.hs0000644000000000000000000001061413623162342014375 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Certificate ( arbitraryX509 , arbitraryX509WithKey , arbitraryX509WithKeyAndUsage , arbitraryDN , arbitraryKeyUsage , simpleCertificate , simpleX509 ) where import Control.Applicative import Test.Tasty.QuickCheck import Data.ASN1.OID import Data.X509 import Data.Hourglass import qualified Data.ByteString as B import PubKey arbitraryDN :: Gen DistinguishedName arbitraryDN = return $ DistinguishedName [] instance Arbitrary Date where arbitrary = do y <- choose (1971, 2035) m <- elements [ January .. December] d <- choose (1, 30) return $ normalizeDate $ Date y m d normalizeDate :: Date -> Date normalizeDate d = timeConvert (timeConvert d :: Elapsed) instance Arbitrary TimeOfDay where arbitrary = do h <- choose (0, 23) mi <- choose (0, 59) se <- choose (0, 59) nsec <- return 0 return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec instance Arbitrary DateTime where arbitrary = DateTime <$> arbitrary <*> arbitrary maxSerial :: Integer maxSerial = 16777216 arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate arbitraryCertificate usageFlags pubKey = do serial <- choose (0,maxSerial) subjectdn <- arbitraryDN validity <- (,) <$> arbitrary <*> arbitrary let sigalg = getSignatureALG pubKey return $ Certificate { certVersion = 3 , certSerial = serial , certSignatureAlg = sigalg , certIssuerDN = issuerdn , certSubjectDN = subjectdn , certValidity = validity , certPubKey = pubKey , certExtensions = Extensions $ Just [ extensionEncode True $ ExtKeyUsage usageFlags ] } where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] simpleCertificate :: PubKey -> Certificate simpleCertificate pubKey = Certificate { certVersion = 3 , certSerial = 0 , certSignatureAlg = getSignatureALG pubKey , certIssuerDN = simpleDN , certSubjectDN = simpleDN , certValidity = (time1, time2) , certPubKey = pubKey , certExtensions = Extensions $ Just [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment] ] } where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) simpleDN = DistinguishedName [] simpleX509 :: PubKey -> SignedCertificate simpleX509 pubKey = let cert = simpleCertificate pubKey sig = replicate 40 1 sigalg = getSignatureALG pubKey (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert in signedExact arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do cert <- arbitraryCertificate usageFlags pubKey sig <- resize 40 $ listOf1 arbitrary let sigalg = getSignatureALG pubKey let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert return signedExact arbitraryX509 :: Gen SignedCertificate arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) arbitraryKeyUsage :: Gen [ExtKeyUsageFlag] arbitraryKeyUsage = sublistOf knownKeyUsage knownKeyUsage :: [ExtKeyUsageFlag] knownKeyUsage = [ KeyUsage_digitalSignature , KeyUsage_keyEncipherment , KeyUsage_keyAgreement ] getSignatureALG :: PubKey -> SignatureALG getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey tls-1.5.4/Tests/Marshalling.hs0000644000000000000000000001452313623162342014417 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Marshalling ( someWords8 , prop_header_marshalling_id , prop_handshake_marshalling_id , prop_handshake13_marshalling_id ) where import Control.Monad import Control.Applicative import Test.Tasty.QuickCheck import Network.TLS.Internal import Network.TLS import qualified Data.ByteString as B import Data.Word import Data.X509 (CertificateChain(..)) import Certificate genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i instance Arbitrary Version where arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12, TLS13 ] instance Arbitrary ProtocolType where arbitrary = elements [ ProtocolType_ChangeCipherSpec , ProtocolType_Alert , ProtocolType_Handshake , ProtocolType_AppData ] instance Arbitrary Header where arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ClientRandom where arbitrary = ClientRandom <$> genByteString 32 instance Arbitrary ServerRandom where arbitrary = ServerRandom <$> genByteString 32 instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int case i of 2 -> Session . Just <$> genByteString 32 _ -> return $ Session Nothing instance Arbitrary HashAlgorithm where arbitrary = elements [ Network.TLS.HashNone , Network.TLS.HashMD5 , Network.TLS.HashSHA1 , Network.TLS.HashSHA224 , Network.TLS.HashSHA256 , Network.TLS.HashSHA384 , Network.TLS.HashSHA512 , Network.TLS.HashIntrinsic ] instance Arbitrary SignatureAlgorithm where arbitrary = elements [ SignatureAnonymous , SignatureRSA , SignatureDSS , SignatureECDSA , SignatureRSApssRSAeSHA256 , SignatureRSApssRSAeSHA384 , SignatureRSApssRSAeSHA512 , SignatureEd25519 , SignatureEd448 , SignatureRSApsspssSHA256 , SignatureRSApsspssSHA384 , SignatureRSApsspssSHA512 ] instance Arbitrary DigitallySigned where arbitrary = DigitallySigned Nothing <$> genByteString 32 arbitraryCiphersIDs :: Gen [Word16] arbitraryCiphersIDs = choose (0,200) >>= vector arbitraryCompressionIDs :: Gen [Word8] arbitraryCompressionIDs = choose (0,200) >>= vector someWords8 :: Int -> Gen [Word8] someWords8 = vector instance Arbitrary ExtensionRaw where arbitrary = let arbitraryContent = choose (0,40) >>= genByteString in ExtensionRaw <$> arbitrary <*> arbitraryContent arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] arbitraryHelloExtensions ver | ver >= SSL3 = arbitrary | otherwise = return [] -- no hello extension with SSLv2 instance Arbitrary CertificateType where arbitrary = elements [ CertificateType_RSA_Sign, CertificateType_DSS_Sign , CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH , CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH , CertificateType_fortezza_dms ] instance Arbitrary Handshake where arbitrary = oneof [ arbitrary >>= \ver -> ClientHello ver <$> arbitrary <*> arbitrary <*> arbitraryCiphersIDs <*> arbitraryCompressionIDs <*> arbitraryHelloExtensions ver <*> return Nothing , arbitrary >>= \ver -> ServerHello ver <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryHelloExtensions ver , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg . CKX_RSA <$> genByteString 48 --, liftM ServerKeyXchg , liftM3 CertRequest arbitrary (return Nothing) (listOf arbitraryDN) , CertVerify <$> arbitrary , Finished <$> genByteString 12 ] arbitraryCertReqContext :: Gen B.ByteString arbitraryCertReqContext = oneof [ return B.empty, genByteString 32 ] instance Arbitrary Handshake13 where arbitrary = oneof [ arbitrary >>= \ver -> ClientHello13 ver <$> arbitrary <*> arbitrary <*> arbitraryCiphersIDs <*> arbitraryHelloExtensions ver , arbitrary >>= \ver -> ServerHello13 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryHelloExtensions ver , NewSessionTicket13 <$> arbitrary <*> arbitrary <*> genByteString 32 -- nonce <*> genByteString 32 -- session ID <*> arbitrary , pure EndOfEarlyData13 , EncryptedExtensions13 <$> arbitrary , CertRequest13 <$> arbitraryCertReqContext <*> arbitrary , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 <$> arbitraryCertReqContext <*> return (CertificateChain certs) <*> replicateM (length certs) arbitrary , CertVerify13 <$> arbitrary <*> genByteString 32 , Finished13 <$> genByteString 12 , KeyUpdate13 <$> elements [ UpdateNotRequested, UpdateRequested ] ] {- quickcheck property -} prop_header_marshalling_id :: Header -> Bool prop_header_marshalling_id x = decodeHeader (encodeHeader x) == Right x prop_handshake_marshalling_id :: Handshake -> Bool prop_handshake_marshalling_id x = decodeHs (encodeHandshake x) == Right x where decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA } prop_handshake13_marshalling_id :: Handshake13 -> Bool prop_handshake13_marshalling_id x = decodeHs (encodeHandshake13 x) == Right x where decodeHs b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b verifyResult :: (t -> b -> r) -> GetResult (t, b) -> r verifyResult fn result = case result of GotPartial _ -> error "got partial" GotError e -> error ("got error: " ++ show e) GotSuccessRemaining _ _ -> error "got remaining byte left" GotSuccess (ty, content) -> fn ty content tls-1.5.4/Tests/PubKey.hs0000644000000000000000000001137113623162342013353 0ustar0000000000000000module PubKey ( arbitraryRSAPair , arbitraryDSAPair , arbitraryEd25519Pair , arbitraryEd448Pair , globalRSAPair , getGlobalRSAPair , dhParams512 , dhParams768 , dhParams1024 , dsaParams , rsaParams ) where import Test.Tasty.QuickCheck import qualified Data.ByteString as B import qualified Crypto.PubKey.DH as DH import Crypto.Error import Crypto.Random import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import Control.Concurrent.MVar import System.IO.Unsafe arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary where rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey) rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey) arbitraryRSAPairWithRNG = RSA.generate 256 0x10001 {-# NOINLINE globalRSAPair #-} globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey) globalRSAPair = unsafePerformIO $ do drg <- drgNew newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG) {-# NOINLINE getGlobalRSAPair #-} getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) rsaParams :: (RSA.PublicKey, RSA.PrivateKey) rsaParams = (pub, priv) where priv = RSA.PrivateKey { RSA.private_pub = pub , RSA.private_d = d , RSA.private_p = 0 , RSA.private_q = 0 , RSA.private_dP = 0 , RSA.private_dQ = 0 , RSA.private_qinv = 0 } pub = RSA.PublicKey { RSA.public_size = (1024 `div` 8), RSA.public_n = n, RSA.public_e = e } n = 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7 e = 0x10001 d = 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 dhParams512 :: DH.Params dhParams512 = DH.Params { DH.params_p = 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb , DH.params_g = 0x2 , DH.params_bits = 512 } -- from RFC 2409 dhParams768 :: DH.Params dhParams768 = DH.Params { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a63a3620ffffffffffffffff , DH.params_g = 0x2 , DH.params_bits = 768 } dhParams1024 :: DH.Params dhParams1024 = DH.Params { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece65381ffffffffffffffff , DH.params_g = 0x2 , DH.params_bits = 1024 } dsaParams :: DSA.Params dsaParams = DSA.Params { DSA.params_p = 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b , DSA.params_g = 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff } arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) arbitraryDSAPair = do priv <- choose (1, DSA.params_q dsaParams) let pub = DSA.calculatePublic dsaParams priv return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv) arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) arbitraryEd25519Pair = do bytes <- vectorOf 32 arbitrary let CryptoPassed priv = Ed25519.secretKey (B.pack bytes) return (Ed25519.toPublic priv, priv) arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) arbitraryEd448Pair = do bytes <- vectorOf 57 arbitrary let CryptoPassed priv = Ed448.secretKey (B.pack bytes) return (Ed448.toPublic priv, priv) tls-1.5.4/Benchmarks/0000755000000000000000000000000013623162342012570 5ustar0000000000000000tls-1.5.4/Benchmarks/Benchmarks.hs0000644000000000000000000001453113623162342015205 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main where import Connection import Certificate import PubKey import Gauge.Main import Control.Concurrent.Chan import Network.TLS import Network.TLS.Extra.Cipher import Data.X509 import Data.X509.Validation import Data.Default.Class import Data.IORef import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L blockCipher :: Cipher blockCipher = Cipher { cipherID = 0xff12 , cipherName = "rsa-id-const" , cipherBulk = Bulk { bulkName = "id" , bulkKeySize = 16 , bulkIVSize = 16 , bulkExplicitIV= 0 , bulkAuthTagLen= 0 , bulkBlockSize = 16 , bulkF = BulkBlockF $ \ _ _ _ m -> (m, B.empty) } , cipherHash = MD5 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } getParams :: Version -> Cipher -> (ClientParams, ServerParams) getParams connectVer cipher = (cParams, sParams) where sParams = def { serverSupported = supported , serverShared = def { sharedCredentials = Credentials [ (CertificateChain [simpleX509 $ PubKeyRSA pubKey], PrivKeyRSA privKey) ] } } cParams = (defaultParamsClient "" B.empty) { clientSupported = supported , clientShared = def { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () , cacheQuery = \_ _ _ -> return ValidationCachePass } } } supported = def { supportedCiphers = [cipher] , supportedVersions = [connectVer] , supportedGroups = [X25519, FFDHE2048] } (pubKey, privKey) = getGlobalRSAPair runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan b -> IO ()) -> (Chan a -> Context -> IO ()) -> a -> IO b runTLSPipe params tlsServer tlsClient d = do withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do writeStart d readResult runTLSPipeSimple :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx d <- recvData ctx writeChan queue d bye ctx tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) byeBye ctx benchConnection :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d benchResumption :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption params !d name = env initializeSession runResumption where initializeSession = do sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs params1 = setPairParamsSessionManagers sessionManagers params _ <- runTLSPipeSimple params1 d Just sessionParams <- readClientSessionRef sessionRefs let params2 = setPairParamsSessionResuming sessionParams params1 newIORef params2 runResumption paramsRef = bench name . nfIO $ do params2 <- readIORef paramsRef runTLSPipeSimple params2 d benchResumption13 :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption13 params !d name = env initializeSession runResumption where initializeSession = do sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs params1 = setPairParamsSessionManagers sessionManagers params _ <- runTLSPipeSimple params1 d newIORef (params1, sessionRefs) -- with TLS13 the sessionId is constantly changing so we must update -- our parameters at each iteration unfortunately runResumption paramsRef = bench name . nfIO $ do (params1, sessionRefs) <- readIORef paramsRef Just sessionParams <- readClientSessionRef sessionRefs let params2 = setPairParamsSessionResuming sessionParams params1 runTLSPipeSimple params2 d benchCiphers :: String -> Version -> B.ByteString -> [Cipher] -> Benchmark benchCiphers name connectVer d = bgroup name . map doBench where doBench cipher = benchResumption13 (getParams connectVer cipher) d (cipherName cipher) main :: IO () main = defaultMain [ bgroup "connection" -- not sure the number actually make sense for anything. improve .. [ benchConnection (getParams SSL3 blockCipher) small "SSL3-256 bytes" , benchConnection (getParams TLS10 blockCipher) small "TLS10-256 bytes" , benchConnection (getParams TLS11 blockCipher) small "TLS11-256 bytes" , benchConnection (getParams TLS12 blockCipher) small "TLS12-256 bytes" ] , bgroup "resumption" [ benchResumption (getParams SSL3 blockCipher) small "SSL3-256 bytes" , benchResumption (getParams TLS10 blockCipher) small "TLS10-256 bytes" , benchResumption (getParams TLS11 blockCipher) small "TLS11-256 bytes" , benchResumption (getParams TLS12 blockCipher) small "TLS12-256 bytes" ] -- Here we try to measure TLS12 and TLS13 performance with AEAD ciphers. -- Resumption and a larger message can be a demonstration of the symmetric -- crypto but for TLS13 this does not work so well because of dhe_psk. , benchCiphers "TLS12" TLS12 large [ cipher_DHE_RSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256GCM_SHA384 , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , cipher_DHE_RSA_AES128CCM_SHA256 , cipher_DHE_RSA_AES128CCM8_SHA256 , cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ] , benchCiphers "TLS13" TLS13 large [ cipher_TLS13_AES128GCM_SHA256 , cipher_TLS13_AES256GCM_SHA384 , cipher_TLS13_CHACHA20POLY1305_SHA256 , cipher_TLS13_AES128CCM_SHA256 , cipher_TLS13_AES128CCM8_SHA256 ] ] where small = B.replicate 256 0 large = B.replicate 102400 0