tls-1.3.8/0000755000000000000000000000000012715016070010512 5ustar0000000000000000tls-1.3.8/CHANGELOG.md0000644000000000000000000001057512715016070012333 0ustar0000000000000000## 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.3.8/LICENSE0000644000000000000000000000273112715016070011522 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.3.8/Setup.hs0000644000000000000000000000005612715016070012147 0ustar0000000000000000import Distribution.Simple main = defaultMain tls-1.3.8/tls.cabal0000644000000000000000000001360612715016070012306 0ustar0000000000000000Name: tls Version: 1.3.8 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 and TLS1.2 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 Tested-With: GHC == 7.0.4, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 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.3 && < 5 , mtl >= 2 , transformers , cereal >= 0.4 , bytestring , data-default-class -- crypto related , memory , cryptonite >= 0.15 -- certificate related , asn1-types >= 0.2.0 , asn1-encoding , x509 >= 1.6.2 && < 1.7.0 , x509-store >= 1.6 , x509-validation >= 1.6.3 && < 1.7.0 , async if flag(network) Build-Depends: network 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 other-modules: Network.TLS.Cap Network.TLS.Struct 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.ECDH Network.TLS.ErrT Network.TLS.Extension Network.TLS.Extension.EC Network.TLS.Handshake Network.TLS.Handshake.Common Network.TLS.Handshake.Certificate Network.TLS.Handshake.Key Network.TLS.Handshake.Client Network.TLS.Handshake.Server Network.TLS.Handshake.Process Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Hooks Network.TLS.IO Network.TLS.Imports Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet Network.TLS.Parameters 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.Receiving Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization Network.TLS.Types Network.TLS.Wire Network.TLS.X509 ghc-options: -Wall -fwarn-tabs -fno-warn-unused-imports if flag(compat) cpp-options: -DSSLV2_COMPATIBLE Test-Suite test-tls type: exitcode-stdio-1.0 hs-source-dirs: Tests Main-is: Tests.hs Build-Depends: base >= 3 && < 5 , mtl , cereal >= 0.3 , data-default-class , tasty , tasty-quickcheck , tls , QuickCheck , cryptonite , bytestring , x509 , x509-validation , hourglass ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fwarn-tabs Benchmark bench-tls hs-source-dirs: Benchmarks Tests Main-Is: Benchmarks.hs type: exitcode-stdio-1.0 Build-depends: base >= 4 && < 5 , tls , x509 , x509-validation , data-default-class , cryptonite , criterion >= 1.0 , mtl , bytestring , hourglass , QuickCheck >= 2 , tasty-quickcheck , tls source-repository head type: git location: git://github.com/vincenthz/hs-tls subdir: core tls-1.3.8/Benchmarks/0000755000000000000000000000000012715016070012567 5ustar0000000000000000tls-1.3.8/Benchmarks/Benchmarks.hs0000644000000000000000000000460212715016070015202 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main where import Connection import Certificate import PubKey import Criterion.Main import Control.Concurrent.Chan import Network.TLS import Data.X509 import Data.X509.Validation import Data.Default.Class import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l 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] } (pubKey, privKey) = getGlobalRSAPair runTLSPipe params tlsServer tlsClient d name = bench name . nfIO $ do (startQueue, resultQueue) <- establishDataPipe params tlsServer tlsClient writeChan startQueue d readChan resultQueue bench1 params !d name = runTLSPipe params tlsServer tlsClient d name where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () main = defaultMain [ bgroup "connection" -- not sure the number actually make sense for anything. improve .. [ bench1 (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" , bench1 (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" , bench1 (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" , bench1 (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" ] ] tls-1.3.8/Network/0000755000000000000000000000000012715016070012143 5ustar0000000000000000tls-1.3.8/Network/TLS.hs0000644000000000000000000000634612715016070013152 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS ( -- * Context configuration ClientParams(..) , ServerParams(..) , DebugParams(..) , ClientHooks(..) , ServerHooks(..) , Supported(..) , Shared(..) , Hooks(..) , Logging(..) , Measurement(..) , CertificateUsage(..) , CertificateRejectReason(..) , defaultParamsClient , MaxFragmentEnum(..) , HashAndSignatureAlgorithm , HashAlgorithm(..) , SignatureAlgorithm(..) , CertificateType(..) -- * raw types , ProtocolType(..) , Header(..) -- * Session , SessionID , SessionData(..) , SessionManager(..) , noSessionManager -- * Backend abstraction , Backend(..) -- * Context object , Context , ctxConnection , TLSParams , HasBackend -- * Creating a context , contextNew , contextNewOnHandle #ifdef INCLUDE_NETWORK , contextNewOnSocket #endif , contextFlush , contextClose , contextHookSetHandshakeRecv , contextHookSetCertificateRecv , contextHookSetLogging , contextModifyHooks -- * Information gathering , Information(..) , unClientRandom , unServerRandom , contextGetInformation -- * Credentials , Credentials(..) , Credential , credentialLoadX509 , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory -- * Initialisation and Termination of context , bye , handshake -- * Next Protocol Negotiation , getNegotiatedProtocol -- * Server Name Indication , getClientSNI -- * High level API , sendData , recvData , recvData' -- * Crypto Key , PubKey(..) , PrivKey(..) -- * Compressions & Predefined compressions , module Network.TLS.Compression -- * Ciphers & Predefined ciphers , module Network.TLS.Cipher -- * Versions , Version(..) -- * Errors , TLSError(..) , KxError(..) , AlertDescription(..) -- * Exceptions , TLSException(..) -- * X509 Validation , ValidationChecks(..) , ValidationHooks(..) -- * X509 Validation Cache , ValidationCache(..) , ValidationCacheResult(..) , exceptionValidationCache ) where import Network.TLS.Backend (Backend(..), HasBackend) import Network.TLS.Struct ( TLSError(..), TLSException(..) , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..) , Header(..), ProtocolType(..), CertificateType(..) , AlertDescription(..) , ClientRandom(..), ServerRandom(..)) import Network.TLS.Crypto (KxError(..)) import Network.TLS.Cipher import Network.TLS.Hooks import Network.TLS.Measurement import Network.TLS.Credentials import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) import Network.TLS.Context import Network.TLS.Parameters import Network.TLS.Core import Network.TLS.Session import Network.TLS.X509 import Network.TLS.Types import Data.X509 (PubKey(..), PrivKey(..)) import Data.X509.Validation tls-1.3.8/Network/TLS/0000755000000000000000000000000012715016070012605 5ustar0000000000000000tls-1.3.8/Network/TLS/Backend.hs0000644000000000000000000000576112715016070014501 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 Data.ByteString (ByteString) import qualified Data.ByteString as B import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) #ifdef INCLUDE_NETWORK import Control.Monad import qualified Network.Socket as Network (Socket, sClose) 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 #ifdef INCLUDE_NETWORK instance HasBackend Network.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Network.sClose sock) (Network.sendAll sock) recvAll where recvAll n = B.concat `fmap` loop n where loop 0 = return [] loop left = do r <- Network.recv sock left if B.null r then return [] else liftM (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 `fmap` 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.3.8/Network/TLS/Cap.hs0000644000000000000000000000065012715016070013645 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.Struct hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool hasHelloExtensions ver = ver >= SSL3 hasExplicitBlockIV ver = ver >= TLS11 tls-1.3.8/Network/TLS/Cipher.hs0000644000000000000000000001164612715016070014363 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 , cipherExchangeNeedMoreData , hasMAC , hasRecordIV ) where import Crypto.Cipher.Types (AuthTag) import Network.TLS.Types (CipherID) import Network.TLS.Struct (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 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 } 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 -> True Just cVer -> cVer <= ver instance Show Cipher where show c = cipherName c instance Eq Cipher where (==) c1 c2 = cipherID c1 == cipherID c2 cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool cipherExchangeNeedMoreData CipherKeyExchange_RSA = False cipherExchangeNeedMoreData CipherKeyExchange_DH_Anon = True cipherExchangeNeedMoreData CipherKeyExchange_DHE_RSA = True cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_RSA = True cipherExchangeNeedMoreData CipherKeyExchange_DHE_DSS = True cipherExchangeNeedMoreData CipherKeyExchange_DH_DSS = False cipherExchangeNeedMoreData CipherKeyExchange_DH_RSA = False cipherExchangeNeedMoreData CipherKeyExchange_ECDH_ECDSA = True cipherExchangeNeedMoreData CipherKeyExchange_ECDH_RSA = True cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_ECDSA = True tls-1.3.8/Network/TLS/Compression.hs0000644000000000000000000000520012715016070015437 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 Data.Word import Network.TLS.Types (CompressionID) import Data.ByteString (ByteString) 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 -> elem (compressionID c) 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.3.8/Network/TLS/Context.hs0000644000000000000000000002000012715016070014555 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(..) , 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 , contextHookSetCertificateRecv , contextHookSetLogging -- * Using context states , throwCore , usingState , usingState_ , runTxState , runRxState , usingHState , getHState , getStateRNG ) where import Network.TLS.Backend import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Cipher (Cipher(..), CipherKeyExchangeType(..)) import Network.TLS.Credentials 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.X509 import Network.TLS.RNG import Data.Maybe (isJust) import Control.Concurrent.MVar import Control.Monad.State 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 getCiphers :: a -> [Cipher] doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> Handshake -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams = ( clientSupported cparams , clientShared cparams , clientDebug cparams ) getTLSRole _ = ClientRole getCiphers cparams = supportedCiphers $ clientSupported cparams doHandshake = handshakeClient doHandshakeWith = handshakeClientWith instance TLSParams ServerParams where getTLSCommonParams sparams = ( serverSupported sparams , serverShared sparams , serverDebug sparams ) getTLSRole _ = ServerRole -- on the server we filter our allowed ciphers here according -- to the credentials and DHE parameters loaded getCiphers sparams = filter authorizedCKE (supportedCiphers $ serverSupported sparams) where authorizedCKE cipher = case cipherKeyExchange cipher of CipherKeyExchange_RSA -> canEncryptRSA CipherKeyExchange_DH_Anon -> canDHE CipherKeyExchange_DHE_RSA -> canSignRSA && canDHE CipherKeyExchange_DHE_DSS -> canSignDSS && canDHE CipherKeyExchange_ECDHE_RSA -> canSignRSA -- unimplemented: non ephemeral DH CipherKeyExchange_DH_DSS -> False CipherKeyExchange_DH_RSA -> False -- unimplemented: EC CipherKeyExchange_ECDH_ECDSA -> False CipherKeyExchange_ECDH_RSA -> False CipherKeyExchange_ECDHE_ECDSA -> False canDHE = isJust $ serverDHEParams sparams canSignDSS = SignatureDSS `elem` signingAlgs canSignRSA = SignatureRSA `elem` signingAlgs canEncryptRSA = isJust $ credentialsFindForDecrypting creds signingAlgs = credentialsListSigningAlgorithms creds creds = sharedCredentials $ serverShared sparams doHandshake = handshakeServer doHandshakeWith = handshakeServerWith -- | 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 ciphers = getCiphers params when (null ciphers) $ error "no ciphers available with those parameters" stvar <- newMVar st eof <- newIORef False established <- newIORef False 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 lockWrite <- newMVar () lockRead <- newMVar () lockState <- newMVar () return $ Context { ctxConnection = getBackend backend , ctxShared = shared , ctxSupported = supported , ctxCiphers = ciphers , ctxState = stvar , ctxTxState = tx , ctxRxState = rx , ctxHandshake = hs , ctxDoHandshake = doHandshake params , ctxDoHandshakeWith = doHandshakeWith params , ctxMeasurement = stats , ctxEOF_ = eof , ctxEstablished_ = established , ctxSSLv2ClientHello = sslv2Compat , ctxNeedEmptyPacket = needEmptyPacket , ctxHooks = hooks , ctxLockWrite = lockWrite , ctxLockRead = lockRead , ctxLockState = lockState } -- | 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 handle params = contextNew handle params {-# 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 }) 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.3.8/Network/TLS/Core.hs0000644000000000000000000001201312715016070014026 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -- | -- 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 -- * Next Protocol Negotiation , getNegotiatedProtocol -- * Server Name Indication , getClientSNI -- * High level API , sendData , recvData , recvData' ) where import Network.TLS.Context import Network.TLS.Struct import Network.TLS.State (getSession) import Network.TLS.Parameters import Network.TLS.IO import Network.TLS.Session import Network.TLS.Handshake import Network.TLS.Util (catchException) import qualified Network.TLS.State as S import qualified Data.ByteString as B import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E import Control.Monad.State -- | 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 = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the Next Protocol Negotiation extension has 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 type HostName = String -- | 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 (checkValid ctx) >> mapM_ sendDataChunk (L.toChunks dataToSend) where sendDataChunk d | B.length d > 16384 = do let (sending, remain) = B.splitAt 16384 d sendPacket ctx $ AppData sending sendDataChunk remain | otherwise = sendPacket ctx $ AppData d -- | recvData get data out of Data packet, and automatically renegotiate if -- a Handshake ClientHello is received recvData :: MonadIO m => Context -> m B.ByteString recvData ctx = liftIO $ do checkValid ctx E.catchJust safeHandleError_EOF doRecv (\() -> return B.empty) where doRecv = do pkt <- withReadLock ctx $ recvPacket ctx either onError process pkt safeHandleError_EOF Error_EOF = Just () safeHandleError_EOF _ = Nothing onError err@(Error_Protocol (reason,fatal,desc)) = terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason onError err = terminate err AlertLevel_Fatal InternalError (show err) process (Handshake [ch@(ClientHello {})]) = withRWLock ctx ((ctxDoHandshakeWith ctx) ctx ch) >> recvData ctx process (Handshake [hr@HelloRequest]) = withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hr) >> recvData ctx process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> 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 "") = recvData ctx process (AppData x) = return x process p = let reason = "unexpected message " ++ show p in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason terminate :: TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate err level desc reason = do session <- usingState_ ctx getSession case session of Session Nothing -> return () Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid catchException (sendPacket ctx $ Alert [(level, desc)]) (\_ -> return ()) setEOF ctx E.throwIO (Terminated False reason err) -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions tryBye = catchException (bye ctx) (\_ -> return ()) {-# 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 = recvData ctx >>= return . L.fromChunks . (:[]) tls-1.3.8/Network/TLS/Credentials.hs0000644000000000000000000001214712715016070015403 0ustar0000000000000000-- | -- Module : Network.TLS.Credentials -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Credentials ( Credential , Credentials(..) , credentialLoadX509 , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory , credentialsFindForSigning , credentialsFindForDecrypting , credentialsListSigningAlgorithms ) where import Data.Monoid import Data.Maybe (catMaybes) import Data.List (find) import Network.TLS.Struct import Network.TLS.X509 import Data.X509.File import Data.X509.Memory import Data.X509 type Credential = (CertificateChain, PrivKey) newtype Credentials = Credentials [Credential] instance Monoid Credentials where mempty = Credentials [] mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2) -- | 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 :: Bytes -> Bytes -> 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 :: Bytes -> [Bytes] -> Bytes -> 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 -> [SignatureAlgorithm] credentialsListSigningAlgorithms (Credentials l) = catMaybes $ map credentialCanSign l credentialsFindForSigning :: SignatureAlgorithm -> Credentials -> Maybe (CertificateChain, PrivKey) credentialsFindForSigning sigAlg (Credentials l) = find forSigning l where forSigning cred = Just sigAlg == credentialCanSign cred credentialsFindForDecrypting :: Credentials -> Maybe (CertificateChain, PrivKey) 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 extensionGet (certExtensions cert) of Nothing -> Just () Just (ExtKeyUsage flags) | KeyUsage_keyEncipherment `elem` flags -> case (pub, priv) of (PubKeyRSA _, PrivKeyRSA _) -> Just () _ -> Nothing | otherwise -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain credentialCanSign :: Credential -> Maybe SignatureAlgorithm credentialCanSign (chain, priv) = case extensionGet (certExtensions cert) of Nothing -> getSignatureAlg pub priv Just (ExtKeyUsage flags) | KeyUsage_digitalSignature `elem` flags -> getSignatureAlg pub priv | otherwise -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain getSignatureAlg :: PubKey -> PrivKey -> Maybe SignatureAlgorithm getSignatureAlg pub priv = case (pub, priv) of (PubKeyRSA _, PrivKeyRSA _) -> Just SignatureRSA (PubKeyDSA _, PrivKeyDSA _) -> Just SignatureDSS --(PubKeyECDSA _, PrivKeyECDSA _) -> Just SignatureECDSA _ -> Nothing tls-1.3.8/Network/TLS/Crypto.hs0000644000000000000000000002421112715016070014421 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.ECDH -- * Hash , hash , Hash(..) , hashName , hashDigestSize , hashBlockSize -- * key exchange generic interface , PubKey(..) , PrivKey(..) , PublicKey , PrivateKey , kxEncrypt , kxDecrypt , kxSign , kxVerify , KxError(..) ) where import qualified Crypto.Hash as H import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) import Data.ByteString (ByteString) import Crypto.Random import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.PubKey.ECC.Types as ECC import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import Crypto.Number.Serialize (os2ip) import Crypto.Number.Basic (numBits) import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..), SerializedPoint(..)) import Network.TLS.Crypto.DH import Network.TLS.Crypto.ECDH import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding (DER(..), BER(..)) import Data.List (find) {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-} type PrivateKey = PrivKey data KxError = RSAError RSA.Error | KxUnsupported deriving (Show) -- 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 `fmap` RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError `fmap` RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) -- Verify that the signature matches the given message, using the -- public key. -- kxVerify :: PublicKey -> Hash -> ByteString -> ByteString -> Bool kxVerify (PubKeyRSA pk) alg msg sign = rsaVerifyHash alg pk msg sign kxVerify (PubKeyDSA pk) _ 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) alg msg sigBS = maybe False id $ do -- get the curve name and the public key data (curveName, pubBS) <- case key of PubKeyEC_Named curveName' pub -> Just (curveName',pub) PubKeyEC_Prime {} -> case find matchPrimeCurve $ enumFrom $ toEnum 0 of Nothing -> Nothing Just curveName' -> Just (curveName', pubkeyEC_pub 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 pubkey <- unserializePoint (ECC.getCurveByName curveName) 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 where matchPrimeCurve c = case ECC.getCurveByName c of ECC.CurveFP (ECC.CurvePrime p cc) -> ECC.ecc_a cc == pubkeyEC_a key && ECC.ecc_b cc == pubkeyEC_b key && ECC.ecc_n cc == pubkeyEC_order key && p == pubkeyEC_prime key _ -> False unserializePoint curve (SerializedPoint bs) = case B.uncons bs of Nothing -> Nothing Just (ptFormat, input) -> case ptFormat of 4 -> if B.length bs == 2 * bytes then Nothing else let (x, y) = B.splitAt bytes input p = ECC.Point (os2ip x) (os2ip y) in if ECC.isPointValid curve p then Just $ ECDSA.PublicKey curve p else Nothing -- 2 and 3 for compressed format. _ -> Nothing where bits = numBits . ECC.ecc_n . ECC.common_curve $ curve bytes = (bits + 7) `div` 8 kxVerify _ _ _ _ = False -- Sign the given message using the private key. -- kxSign :: MonadRandom r => PrivateKey -> Hash -> ByteString -> r (Either KxError ByteString) kxSign (PrivKeyRSA pk) hashAlg msg = generalizeRSAError `fmap` rsaSignHash hashAlg pk msg kxSign (PrivKeyDSA pk) _ 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 _ _ _ = -- 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 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) noHash :: Maybe H.MD5 noHash = Nothing tls-1.3.8/Network/TLS/ErrT.hs0000644000000000000000000000121312715016070014012 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.3.8/Network/TLS/Extension.hs0000644000000000000000000003502212715016070015117 0ustar0000000000000000-- | -- 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_NextProtocolNegotiation , extensionID_ApplicationLayerProtocolNegotiation , extensionID_EllipticCurves , extensionID_EcPointFormats , extensionID_Heartbeat , extensionID_SignatureAlgorithms -- all implemented extensions , ServerNameType(..) , ServerName(..) , MaxFragmentLength(..) , MaxFragmentEnum(..) , SecureRenegotiation(..) , NextProtocolNegotiation(..) , ApplicationLayerProtocolNegotiation(..) , EllipticCurvesSupported(..) , NamedCurve(..) , CurveName(..) , EcPointFormatsSupported(..) , EcPointFormat(..) , SessionTicket(..) , HeartBeat(..) , HeartBeatMode(..) , SignatureAlgorithms(..) , availableEllipticCurves ) where import Control.Monad import Data.Word import Data.Maybe (fromMaybe, catMaybes) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Network.TLS.Extension.EC import Network.TLS.Struct (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm) import Network.TLS.Wire import Network.TLS.Imports import Network.TLS.Packet (putSignatureHashAlgorithm, getSignatureHashAlgorithm) type HostName = String -- 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_EllipticCurves , 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_NextProtocolNegotiation , 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_EllipticCurves = 0xa -- RFC4492 extensionID_EcPointFormats = 0xb -- RFC4492 extensionID_SRP = 0xc -- RFC5054 extensionID_SignatureAlgorithms = 0xd -- RFC5246 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 -- draft-ietf-tls-session-hash. expires 2015-09-26 extensionID_SessionTicket = 0x23 -- RFC4507 extensionID_NextProtocolNegotiation = 0x3374 -- obsolete 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_EllipticCurves , 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_NextProtocolNegotiation , extensionID_SecureRenegotiation ] -- | all supported extensions by the implementation supportedExtensions :: [ExtensionID] supportedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ApplicationLayerProtocolNegotiation , extensionID_SecureRenegotiation , extensionID_NextProtocolNegotiation , extensionID_EllipticCurves , extensionID_EcPointFormats , extensionID_SignatureAlgorithms ] -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID extensionDecode :: Bool -> 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 data 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 _ = runGetMaybe (getWord16 >>= \len -> getList (fromIntegral len) getServerName >>= return . ServerName) where getServerName = do ty <- getWord8 sname <- getOpaque16 return (1+2+B.length sname, case ty of 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion _ -> ServerNameOther (ty, sname)) -- | Max fragment extension with length from 512 bytes to 4096 bytes data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum deriving (Show,Eq) data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096 deriving (Show,Eq) instance Extension MaxFragmentLength where extensionID _ = extensionID_MaxFragmentLength extensionEncode (MaxFragmentLength e) = B.singleton $ marshallSize e where marshallSize MaxFragment512 = 1 marshallSize MaxFragment1024 = 2 marshallSize MaxFragment2048 = 3 marshallSize MaxFragment4096 = 4 extensionDecode _ = runGetMaybe (MaxFragmentLength . unmarshallSize <$> getWord8) where unmarshallSize 1 = MaxFragment512 unmarshallSize 2 = MaxFragment1024 unmarshallSize 3 = MaxFragment2048 unmarshallSize 4 = MaxFragment4096 unmarshallSize n = error ("unknown max fragment size " ++ show 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 isServerHello = runGetMaybe $ do opaque <- getOpaque8 if isServerHello then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque in return $ SecureRenegotiation cvd (Just svd) else return $ SecureRenegotiation opaque Nothing -- | Next Protocol Negotiation data NextProtocolNegotiation = NextProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension NextProtocolNegotiation where extensionID _ = extensionID_NextProtocolNegotiation extensionEncode (NextProtocolNegotiation bytes) = runPut $ mapM_ putOpaque8 bytes extensionDecode _ = runGetMaybe (NextProtocolNegotiation <$> getNPN) where getNPN = do avail <- remaining case avail of 0 -> return [] _ -> do liftM2 (:) getOpaque8 getNPN -- | Application Layer Protocol Negotiation (ALPN) data ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension ApplicationLayerProtocolNegotiation where extensionID _ = extensionID_ApplicationLayerProtocolNegotiation extensionEncode (ApplicationLayerProtocolNegotiation bytes) = runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes extensionDecode _ = runGetMaybe (ApplicationLayerProtocolNegotiation <$> getALPN) where getALPN = do _ <- getWord16 getALPN' getALPN' = do avail <- remaining case avail of 0 -> return [] _ -> (:) <$> getOpaque8 <*> getALPN' data EllipticCurvesSupported = EllipticCurvesSupported [NamedCurve] deriving (Show,Eq) data NamedCurve = SEC CurveName | BrainPool BrainPoolCurve | NamedCurve_arbitrary_explicit_prime_curves | NamedCurve_arbitrary_explicit_char2_curves deriving (Show,Eq) data BrainPoolCurve = BrainPoolP512R1 -- 28 | BrainPoolP384R1 -- 27 | BrainPoolP256R1 -- 26 deriving (Show,Eq) availableEllipticCurves :: [NamedCurve] availableEllipticCurves = [SEC SEC_p256r1, SEC SEC_p521r1] instance EnumSafe16 NamedCurve where fromEnumSafe16 NamedCurve_arbitrary_explicit_prime_curves = 0xFF01 fromEnumSafe16 NamedCurve_arbitrary_explicit_char2_curves = 0xFF02 fromEnumSafe16 (SEC nc) = maybe (error "named curve: internal error") id $ fromCurveName nc fromEnumSafe16 (BrainPool BrainPoolP512R1) = 28 fromEnumSafe16 (BrainPool BrainPoolP384R1) = 27 fromEnumSafe16 (BrainPool BrainPoolP256R1) = 26 toEnumSafe16 0xFF01 = Just NamedCurve_arbitrary_explicit_prime_curves toEnumSafe16 0xFF02 = Just NamedCurve_arbitrary_explicit_char2_curves toEnumSafe16 26 = Just (BrainPool BrainPoolP256R1) toEnumSafe16 27 = Just (BrainPool BrainPoolP384R1) toEnumSafe16 28 = Just (BrainPool BrainPoolP512R1) toEnumSafe16 n = SEC <$> toCurveName n -- on decode, filter all unknown curves instance Extension EllipticCurvesSupported where extensionID _ = extensionID_EllipticCurves extensionEncode (EllipticCurvesSupported curves) = runPut $ putWords16 $ map fromEnumSafe16 curves extensionDecode _ = runGetMaybe (EllipticCurvesSupported . catMaybes . map toEnumSafe16 <$> getWords16) data 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 _ = runGetMaybe (EcPointFormatsSupported . catMaybes . map toEnumSafe8 <$> getWords8) data SessionTicket = SessionTicket deriving (Show,Eq) instance Extension SessionTicket where extensionID _ = extensionID_SessionTicket extensionEncode (SessionTicket {}) = runPut $ return () extensionDecode _ = runGetMaybe (return SessionTicket) data 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 _ bs = case runGetMaybe (toEnumSafe8 <$> getWord8) bs of Just (Just mode) -> Just $ HeartBeat mode _ -> Nothing data 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 _ = runGetMaybe $ do len <- getWord16 SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) tls-1.3.8/Network/TLS/Extra.hs0000644000000000000000000000047412715016070014231 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 ) where import Network.TLS.Extra.Cipher tls-1.3.8/Network/TLS/Handshake.hs0000644000000000000000000000222712715016070015032 0ustar0000000000000000-- | -- Module : Network.TLS.Handshake -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake ( handshake , handshakeClientWith , handshakeServerWith , handshakeClient , handshakeServer ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.IO import Network.TLS.Util (catchException) import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State import Control.Exception (fromException) -- | 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 $ handleException $ withRWLock ctx (ctxDoHandshake ctx $ ctx) where handleException f = catchException f $ \exception -> do let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception setEstablished ctx False sendPacket ctx (errorToAlert tlserror) handshakeFailed tlserror tls-1.3.8/Network/TLS/Hooks.hs0000644000000000000000000000315512715016070014230 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.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 certificate chain message received , hookRecvCertificates :: CertificateChain -> IO () -- | hooks on IO and packets, receiving and sending. , hookLogging :: Logging } defaultHooks :: Hooks defaultHooks = Hooks { hookRecvHandshake = \hs -> return hs , hookRecvCertificates = return . const () , hookLogging = def } instance Default Hooks where def = defaultHooks tls-1.3.8/Network/TLS/Imports.hs0000644000000000000000000000136612715016070014604 0ustar0000000000000000-- | -- Module : Network.TLS.Imports -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE NoImplicitPrelude #-} module Network.TLS.Imports ( -- generic exports Control.Applicative.Applicative(..) , (Control.Applicative.<$>) , Data.Monoid.Monoid(..) -- project definition , Bytes , showBytesHex ) where import qualified Control.Applicative import qualified Data.Monoid import qualified Data.ByteString as B import Data.ByteArray.Encoding as B import qualified Prelude type Bytes = B.ByteString showBytesHex :: Bytes -> Prelude.String showBytesHex bs = Prelude.show (B.convertToBase B.Base16 bs :: Bytes) tls-1.3.8/Network/TLS/Internal.hs0000644000000000000000000000116412715016070014717 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.Packet , module Network.TLS.Receiving , module Network.TLS.Sending , module Network.TLS.Wire , sendPacket , recvPacket ) where import Network.TLS.Struct import Network.TLS.Packet import Network.TLS.Receiving import Network.TLS.Sending import Network.TLS.Wire import Network.TLS.Core (sendPacket, recvPacket) tls-1.3.8/Network/TLS/IO.hs0000644000000000000000000001210612715016070013450 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.IO -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.IO ( checkValid , sendPacket , recvPacket ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.Hooks import Network.TLS.Sending import Network.TLS.Receiving import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.IORef import Control.Monad.State import Control.Exception (throwIO) import System.IO.Error (mkIOError, eofErrorType) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx unless established $ liftIO $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing readExact :: Context -> Int -> IO Bytes readExact ctx sz = do hdrbs <- liftIO $ contextRecv ctx sz when (B.length hdrbs < sz) $ do setEOF ctx if B.null hdrbs then throwCore Error_EOF else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) return hdrbs -- | 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 -> Context -- ^ TLS context -> IO (Either TLSError (Record Plaintext)) recvRecord compatSSLv2 ctx #ifdef SSLV2_COMPATIBLE | compatSSLv2 = do header <- readExact ctx 2 if B.head header < 0x80 then readExact ctx 3 >>= either (return . Left) recvLength . decodeHeader . B.append header else either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header #endif | otherwise = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader where recvLength header@(Header _ _ readlen) | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded | otherwise = readExact ctx (fromIntegral readlen) >>= getRecord header #ifdef SSLV2_COMPATIBLE recvDeprecatedLength readlen | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do content <- readExact ctx (fromIntegral readlen) case decodeDeprecatedHeader readlen content of Left err -> return $ Left err Right header -> getRecord header content #endif maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext)) getRecord header content = do liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) -- | 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 erecord <- recvRecord compatSSLv2 ctx case erecord of Left err -> return $ Left err Right record -> do pktRecv <- processPacket ctx record pkt <- case pktRecv of Right (Handshake hss) -> ctxWithHooks ctx $ \hooks -> (mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake _ -> return pktRecv case pkt of Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p _ -> return () when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx return pkt -- | 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. withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty edataToSend <- liftIO $ do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) writePacket ctx pkt case edataToSend of Left err -> throwCore err Right dataToSend -> liftIO $ do withLog ctx $ \logging -> loggingIOSent logging dataToSend contextSend ctx dataToSend where isNonNullAppData (AppData b) = not $ B.null b isNonNullAppData _ = False tls-1.3.8/Network/TLS/MAC.hs0000644000000000000000000000443112715016070013543 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_MD5SHA1 ) where import Network.TLS.Crypto import qualified Data.ByteString as B import Data.ByteString (ByteString) import Data.Bits (xor) 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 = fromIntegral $ 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.pack $ B.zipWith 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 tls-1.3.8/Network/TLS/Measurement.hs0000644000000000000000000000267712715016070015442 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 Data.Word -- | 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.3.8/Network/TLS/Packet.hs0000644000000000000000000006560412715016070014363 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 , encodeHandshakes , encodeHandshakeHeader , encodeHandshakeContent -- * marshall functions for change cipher spec message , decodeChangeCipherSpec , encodeChangeCipherSpec , decodePreMasterSecret , encodePreMasterSecret , encodeSignedDHParams , encodeSignedECDHParams , decodeReallyServerKeyXchgAlgorithmData -- * generate things for packet content , generateMasterSecret , generateKeyBlock , generateClientFinished , generateServerFinished , generateCertificateVerify_SSL -- * for extensions parsing , getSignatureHashAlgorithm , putSignatureHashAlgorithm ) where import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap import Data.Maybe (fromJust) import Data.Word import Control.Monad import Data.ASN1.Types (fromASN1, toASN1) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..)) import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..)) import Network.TLS.Util.Serialization (os2ip,i2ospOf_) import Data.ByteString (ByteString) 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 , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension } 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 putVersion :: Version -> Put putVersion 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" $ liftM3 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 >> putVersion 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 liftM2 (:) 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, Bytes) 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 HandshakeType_NPN -> do unless (cParamsSupportNPN cp) $ fail "unsupported handshake type" decodeNextProtocolNegotiation 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 fmap 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 fmap 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) decodeNextProtocolNegotiation :: Get Handshake decodeNextProtocolNegotiation = do opaque <- getOpaque8 _ <- getOpaque8 -- ignore padding return $ HsNextProtocolNegotiation opaque decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 sigHashAlgs <- if cParamsVersion cp >= TLS12 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) else return Nothing 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" dNames <- getList (fromIntegral dNameLen) getDName return $ CertRequest certTypes sigHashAlgs dNames where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) getDName = do dName <- getOpaque16 when (B.length dName == 0) $ fail "certrequest: invalid DN length" dn <- case decodeASN1' DER dName of Left e -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e) Right asn1s -> case fromASN1 asn1s of Left e -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e) Right (d,_) -> return d 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 = do len <- getWord8 formatTy <- getWord8 case formatTy of 4 -> do -- uncompressed let siz = fromIntegral len `div` 2 xb <- getBytes siz yb <- getBytes siz let x = os2ip xb y = os2ip yb return $ CKX_ECDH $ ecdhPublic x y siz _ -> error ("unsupported EC format type: " ++ show formatTy) 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 dhparams <- getServerECDHParams signature <- getDigitallySigned ver return $ SKX_ECDHE_RSA dhparams signature CipherKeyExchange_ECDHE_ECDSA -> do dhparams <- getServerECDHParams signature <- getDigitallySigned ver return $ SKX_ECDHE_ECDSA dhparams 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 = fromIntegral $ B.length content in let header = case o of ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in B.concat [ header, content ] encodeHandshakes :: [Handshake] -> ByteString encodeHandshakes hss = B.concat $ map encodeHandshake hss 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 putVersion version putClientRandom32 random putSession session putWords16 cipherIDs putWords8 compressionIDs putExtensions exts return () encodeHandshakeContent (ServerHello version random session cipherID compressionID exts) = putVersion 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 clientECDHPublic -> do let (x,y,siz) = ecdhUnwrapPublic clientECDHPublic let xb = i2ospOf_ siz x yb = i2ospOf_ siz y putOpaque8 $ B.concat [B.singleton 4,xb,yb] 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 encodeCertAuthorities certAuthorities where -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn -- Encode a list of distinguished names. encodeCertAuthorities certAuths = do enc <- mapM encodeCA certAuths let totLength = sum $ map (((+) 2) . B.length) enc putWord16 (fromIntegral totLength) mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned encodeHandshakeContent (Finished opaque) = putBytes opaque encodeHandshakeContent (HsNextProtocolNegotiation protocol) = do putOpaque8 protocol putOpaque8 $ B.replicate paddingLen 0 where paddingLen = 32 - ((B.length protocol + 2) `mod` 32) {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get Bytes getRandom32 = getBytes 32 getServerRandom32 :: Get ServerRandom getServerRandom32 = ServerRandom <$> getRandom32 getClientRandom32 :: Get ClientRandom getClientRandom32 = ClientRandom <$> getRandom32 putRandom32 :: Bytes -> 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 <- fromJust . valToType <$> getWord8 s <- fromJust . valToType <$> getWord8 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] getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8 case curveType of 1 -> do -- explicit prime _prime <- getOpaque8 _a <- getOpaque8 _b <- getOpaque8 _base <- getOpaque8 _order <- getOpaque8 _cofactor <- getOpaque8 error "cannot handle explicit prime ECDH Params" 2 -> -- explicit_char2 error "cannot handle explicit char2 ECDH Params" 3 -> do -- ECParameters ECCurveType: curve name type w16 <- getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint let xy = B.drop 1 mxy siz = B.length xy `div` 2 (xb,yb) = B.splitAt siz xy x = os2ip xb y = os2ip yb return $ ServerECDHParams (ecdhParams w16) (ecdhPublic x y siz) _ -> error "unknown type for ECDH Params" putServerECDHParams :: ServerECDHParams -> Put putServerECDHParams (ServerECDHParams ecdhparams ecdhpub) = do let (w16,x,y,siz) = ecdhUnwrap ecdhparams ecdhpub putWord8 3 -- ECParameters ECCurveType: curve name type putWord16 w16 -- ECParameters NamedCurve let xb = i2ospOf_ siz x yb = i2ospOf_ siz y putOpaque8 $ B.concat [B.singleton 4,xb,yb] -- 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 :: Bytes -> Either TLSError (Version, Bytes) decodePreMasterSecret = runGetErr "pre-master-secret" $ do liftM2 (,) getVersion (getBytes 46) encodePreMasterSecret :: Version -> Bytes -> Bytes encodePreMasterSecret version bytes = runPut (putVersion 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 -> Bytes -> Either TLSError ServerKeyXchgAlgorithmData decodeReallyServerKeyXchgAlgorithmData ver cke = runGetErr "server-key-xchg-algorithm-data" (decodeServerKeyXchgAlgorithmData ver cke) {- - generate things for packet content -} type PRF = Bytes -> Bytes -> Int -> Bytes generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> Bytes 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 -> Bytes 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 -> preMaster -> ClientRandom -> ServerRandom -> Bytes generateMasterSecret SSL2 = generateMasterSecret_SSL generateMasterSecret SSL3 = generateMasterSecret_SSL generateMasterSecret TLS10 = generateMasterSecret_TLS prf_MD5SHA1 generateMasterSecret TLS11 = generateMasterSecret_TLS prf_MD5SHA1 generateMasterSecret TLS12 = generateMasterSecret_TLS prf_SHA256 generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes 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 -> Bytes -> Int -> Bytes 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 -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes generateKeyBlock SSL2 = generateKeyBlock_SSL generateKeyBlock SSL3 = generateKeyBlock_SSL generateKeyBlock TLS10 = generateKeyBlock_TLS prf_MD5SHA1 generateKeyBlock TLS11 = generateKeyBlock_TLS prf_MD5SHA1 generateKeyBlock TLS12 = generateKeyBlock_TLS prf_SHA256 generateFinished_TLS :: PRF -> Bytes -> Bytes -> HashCtx -> Bytes generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 where seed = B.concat [ label, hashFinal hashctx ] generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> Bytes 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 -> Bytes -> HashCtx -> Bytes generateClientFinished ver | ver < TLS10 = generateFinished_SSL "CLNT" | ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "client finished" | otherwise = generateFinished_TLS prf_SHA256 "client finished" generateServerFinished :: Version -> Bytes -> HashCtx -> Bytes generateServerFinished ver | ver < TLS10 = generateFinished_SSL "SRVR" | ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "server finished" | otherwise = generateFinished_TLS prf_SHA256 "server finished" generateCertificateVerify_SSL :: Bytes -> HashCtx -> Bytes generateCertificateVerify_SSL = generateFinished_SSL "" encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> Bytes 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 -> Bytes encodeSignedECDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams tls-1.3.8/Network/TLS/Parameters.hs0000644000000000000000000003110712715016070015246 0ustar0000000000000000 {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Parameters -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Parameters ( ClientParams(..) , ServerParams(..) , CommonParams , DebugParams(..) , ClientHooks(..) , ServerHooks(..) , Supported(..) , Shared(..) -- * special default , defaultParamsClient -- * Parameters , MaxFragmentEnum(..) , 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 Data.Default.Class import qualified Data.ByteString as B #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif type HostName = String 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 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' , debugPrintSeed :: Seed -> IO () } defaultDebugParams :: DebugParams defaultDebugParams = DebugParams { debugSeed = Nothing , debugPrintSeed = const (return ()) } instance Show DebugParams where show _ = "DebugParams" instance Default DebugParams where def = defaultDebugParams data ClientParams = ClientParams { 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. , clientServerIdentification :: (HostName, Bytes) -- | 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). , clientUseServerNameIndication :: Bool -- | try to establish a connection using this session. , clientWantSessionResume :: Maybe (SessionID, SessionData) , clientShared :: Shared , clientHooks :: ClientHooks , clientSupported :: Supported , clientDebug :: DebugParams } deriving (Show) defaultParamsClient :: HostName -> Bytes -> ClientParams defaultParamsClient serverName serverId = ClientParams { clientWantSessionResume = Nothing , clientUseMaxFragmentLength = Nothing , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientShared = def , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams } data ServerParams = ServerParams { -- | request a certificate from client. 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. , serverCACertificates :: [SignedCertificate] -- | Server Optional Diffie Hellman parameters. If this value is not -- properly set, no Diffie Hellman key exchange will take place. , serverDHEParams :: Maybe DHParams , serverShared :: Shared , serverHooks :: ServerHooks , serverSupported :: Supported , serverDebug :: DebugParams } deriving (Show) defaultParamsServer :: ServerParams defaultParamsServer = ServerParams { serverWantClientCert = False , serverCACertificates = [] , serverDHEParams = Nothing , serverHooks = def , serverShared = def , serverSupported = def , serverDebug = defaultDebugParams } 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 chosed. supportedVersions :: [Version] -- | Supported cipher methods , supportedCiphers :: [Cipher] -- | supported compressions methods , supportedCompressions :: [Compression] -- | All supported hash/signature algorithms pair for client -- certificate verification, ordered by decreasing priority. , 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. , 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. , supportedClientInitiatedRenegotiation :: Bool -- | Set if we support session. , supportedSession :: Bool -- | Support for fallback SCSV defined in RFC7507. -- If 'True', servers reject handshakes which suggest -- a lower protocol than the highest protocol supported. , 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. , supportedEmptyPacket :: Bool } deriving (Show,Eq) defaultSupported :: Supported defaultSupported = Supported { supportedVersions = [TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA256, SignatureRSA) , (Struct.HashSHA224, SignatureRSA) , (Struct.HashSHA1, SignatureRSA) , (Struct.HashSHA1, SignatureDSS) ] , supportedSecureRenegotiation = True , supportedClientInitiatedRenegotiation = False , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True } instance Default Supported where def = defaultSupported data Shared = Shared { sharedCredentials :: Credentials , sharedSessionManager :: SessionManager , sharedCAStore :: CertificateStore , sharedValidationCache :: ValidationCache } instance Show Shared where show _ = "Shared" instance Default Shared where def = Shared { sharedCAStore = mempty , sharedCredentials = mempty , sharedSessionManager = noSessionManager , sharedValidationCache = def } -- | A set of callbacks run by the clients for various corners of TLS establishment data ClientHooks = ClientHooks { -- | This action is called when the server sends a -- certificate request. The parameter is the information -- from the request. The action should select a certificate -- chain of one of the given certificate types where the -- last certificate in the chain should be signed by one of -- the given distinguished names. Each certificate should -- be signed by the following one, except for the last. At -- least the first of the certificates in the chain must -- have a corresponding private key, because that is used -- for signing the certificate verify message. -- -- Note that is is the responsibility of this action to -- select a certificate matching one of the requested -- certificate types. Returning a non-matching one will -- lead to handshake failure later. -- -- Returning a certificate chain not matching the -- distinguished names may lead to problems or not, -- depending whether the server accepts it. onCertificateRequest :: ([CertificateType], Maybe [HashAndSignatureAlgorithm], [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey)) , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] , onSuggestALPN :: IO (Maybe [B.ByteString]) } defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks { onCertificateRequest = \ _ -> return Nothing , onNPNServerSuggest = Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing } 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. onClientCertificate :: CertificateChain -> IO CertificateUsage -- | This action is called when the client certificate -- cannot be verified. A 'Nothing' argument indicates a -- wrong signature, a 'Just e' message signals a crypto -- error. , 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. , 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. , onServerNameIndication :: Maybe HostName -> IO Credentials -- | suggested next protocols accoring to the next protocol negotiation extension. , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- | at each new handshake, we call this hook to see if we allow handshake to happens. , onNewHandshake :: Measurement -> IO Bool , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) } defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks { onCipherChoosing = \_ -> head , onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False , onServerNameIndication = \_ -> return mempty , onSuggestNextProtocols = return Nothing , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks tls-1.3.8/Network/TLS/Receiving.hs0000644000000000000000000000621312715016070015056 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 ) where import Control.Monad.State import Control.Concurrent.MVar import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.ErrT import Network.TLS.Record import Network.TLS.Packet import Network.TLS.Wire import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util 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 npn <- getExtensionNPN let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg , cParamsSupportNPN = npn } -- 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 maybe decodeHandshakeRecord id 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:) `fmap` 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) tls-1.3.8/Network/TLS/Record.hs0000644000000000000000000000216312715016070014361 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.3.8/Network/TLS/RNG.hs0000644000000000000000000000113612715016070013570 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.3.8/Network/TLS/Sending.hs0000644000000000000000000000763312715016070014541 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 (writePacket) where import Control.Applicative import Control.Monad.State import Control.Concurrent.MVar import Data.IORef import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Types (Role(..)) import Network.TLS.Cap import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util -- | 'makePacketData' create a Header and a content bytestring related to a packet -- this doesn't change any state makeRecord :: Packet -> RecordM (Record Plaintext) makeRecord pkt = do ver <- getRecordVersion return $ Record (packetType pkt) ver (fragmentPlaintext $ writePacketContent pkt) where writePacketContent (Handshake hss) = encodeHandshakes hss writePacketContent (Alert a) = encodeAlerts a writePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec writePacketContent (AppData x) = x -- | marshall packet data encodeRecord :: Record Ciphertext -> RecordM ByteString encodeRecord record = return $ B.concat [ encodeHeader hdr, content ] where (hdr, content) = recordToRaw record -- | writePacket transform a packet into marshalled data related to current state -- and updating state on the go writePacket :: Context -> Packet -> IO (Either TLSError ByteString) writePacket ctx pkt@(Handshake hss) = do forM_ hss $ \hs -> do case hs of Finished fdata -> usingState_ ctx $ updateVerifiedData ClientRole fdata _ -> return () let encoded = encodeHandshake hs usingHState ctx $ do when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord) writePacket ctx pkt = do d <- prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord) when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx return d -- 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 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) tls-1.3.8/Network/TLS/Session.hs0000644000000000000000000000162212715016070014565 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 when a session is established. , sessionEstablish :: SessionID -> SessionData -> IO () -- | used when a session is invalidated. , sessionInvalidate :: SessionID -> IO () } noSessionManager :: SessionManager noSessionManager = SessionManager { sessionResume = \_ -> return Nothing , sessionEstablish = \_ _ -> return () , sessionInvalidate = \_ -> return () } tls-1.3.8/Network/TLS/State.hs0000644000000000000000000002316212715016070014225 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 , setExtensionNPN , getExtensionNPN , setExtensionALPN , getExtensionALPN , setNegotiatedProtocol , getNegotiatedProtocol , setServerNextProtocolSuggest , getServerNextProtocolSuggest , setClientALPNSuggest , getClientALPNSuggest , setClientEllipticCurveSuggest , getClientEllipticCurveSuggest , setClientEcPointFormatSuggest , getClientEcPointFormatSuggest , getClientCertificateChain , setClientCertificateChain , setClientSNI , getClientSNI , getVerifiedData , setSession , getSession , isSessionResuming , isClientContext -- * random , genRandom , withRNG ) where import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.RNG import Network.TLS.Types (Role(..)) import Network.TLS.Wire (GetContinuation) import Network.TLS.Extension import qualified Data.ByteString as B import Control.Monad.State import Network.TLS.ErrT import Crypto.Random import Data.X509 (CertificateChain) type HostName = String data TLSState = TLSState { stSession :: Session , stSessionResuming :: Bool , stSecureRenegotiation :: Bool -- RFC 5746 , stClientVerifiedData :: Bytes -- RFC 5746 , stServerVerifiedData :: Bytes -- RFC 5746 , stExtensionNPN :: Bool -- NPN draft extension , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, Bytes)) , stNegotiatedProtocol :: Maybe B.ByteString -- NPN and ALPN protocol , stServerNextProtocolSuggest :: Maybe [B.ByteString] , stClientALPNSuggest :: Maybe [B.ByteString] , stClientEllipticCurveSuggest :: Maybe [NamedCurve] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , stClientSNI :: Maybe HostName , stRandomGen :: StateRNG , stVersion :: Maybe Version , stClientContext :: Role } 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 , stExtensionNPN = False , stExtensionALPN = False , stHandshakeRecordCont = Nothing , stNegotiatedProtocol = Nothing , stServerNextProtocolSuggest = Nothing , stClientALPNSuggest = Nothing , stClientEllipticCurveSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing , stRandomGen = rng , stVersion = Nothing , stClientContext = clientContext } updateVerifiedData :: Role -> Bytes -> 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 finishHandshakeTypeMaterial HandshakeType_NPN = 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 certVerifyHandshakeTypeMaterial HandshakeType_NPN = 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 = maybe (error $ "internal error: version hasn't been set yet") id <$> gets stVersion getVersionWithDefault :: Version -> TLSSt Version getVersionWithDefault defaultVer = maybe defaultVer id <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt () setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b }) getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionNPN :: Bool -> TLSSt () setExtensionNPN b = modify (\st -> st { stExtensionNPN = b }) getExtensionNPN :: TLSSt Bool getExtensionNPN = gets stExtensionNPN 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 setServerNextProtocolSuggest :: [B.ByteString] -> TLSSt () setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps}) getServerNextProtocolSuggest :: TLSSt (Maybe [B.ByteString]) getServerNextProtocolSuggest = gets stServerNextProtocolSuggest setClientALPNSuggest :: [B.ByteString] -> TLSSt () setClientALPNSuggest ps = modify (\st -> st { stClientALPNSuggest = Just ps}) getClientALPNSuggest :: TLSSt (Maybe [B.ByteString]) getClientALPNSuggest = gets stClientALPNSuggest setClientEllipticCurveSuggest :: [NamedCurve] -> TLSSt () setClientEllipticCurveSuggest nc = modify (\st -> st { stClientEllipticCurveSuggest = Just nc}) getClientEllipticCurveSuggest :: TLSSt (Maybe [NamedCurve]) getClientEllipticCurveSuggest = gets stClientEllipticCurveSuggest 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 Bytes getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) isClientContext :: TLSSt Role isClientContext = gets stClientContext genRandom :: Int -> TLSSt Bytes 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 tls-1.3.8/Network/TLS/Struct.hs0000644000000000000000000004332112715016070014430 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 ( Bytes , Version(..) , ConnectionEnd(..) , CipherType(..) , CipherData(..) , ExtensionID , ExtensionRaw(..) , CertificateType(..) , HashAlgorithm(..) , SignatureAlgorithm(..) , HashAndSignatureAlgorithm , DigitallySigned(..) , ProtocolType(..) , TLSError(..) , TLSException(..) , DistinguishedName , BigNum(..) , bigNumToInteger , bigNumFromInteger , ServerDHParams(..) , serverDHParamsToParams , serverDHParamsToPublic , serverDHParamsFrom , ServerECDHParams(..) , ServerRSAParams(..) , ServerKeyXchgAlgorithmData(..) , ClientKeyXchgAlgorithmData(..) , Packet(..) , Header(..) , ServerRandom(..) , ClientRandom(..) , serverRandom , clientRandom , FinishedData , SessionID , Session(..) , SessionData(..) , AlertLevel(..) , AlertDescription(..) , HandshakeType(..) , Handshake(..) , numericalVer , verOfNum , TypeValuable, valOfType, valToType , EnumSafe8(..) , EnumSafe16(..) , packetType , typeOfHandshake ) where import Data.ByteString (ByteString) import qualified Data.ByteString as B (length) import Data.Word import Data.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Exception (Exception(..)) import Network.TLS.Types import Network.TLS.Crypto.DH import Network.TLS.Crypto.ECDH 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 :: Bytes , cipherDataMAC :: Maybe Bytes , cipherDataPadding :: Maybe Bytes } deriving (Show,Eq) data CertificateType = CertificateType_RSA_Sign -- TLS10 | CertificateType_DSS_Sign -- TLS10 | CertificateType_RSA_Fixed_DH -- TLS10 | CertificateType_DSS_Fixed_DH -- TLS10 | CertificateType_RSA_Ephemeral_DH -- TLS12 | CertificateType_DSS_Ephemeral_DH -- TLS12 | CertificateType_fortezza_dms -- TLS12 | CertificateType_Unknown Word8 deriving (Show,Eq) data HashAlgorithm = HashNone | HashMD5 | HashSHA1 | HashSHA224 | HashSHA256 | HashSHA384 | HashSHA512 | HashOther Word8 deriving (Show,Eq) data SignatureAlgorithm = SignatureAnonymous | SignatureRSA | SignatureDSS | SignatureECDSA | SignatureOther Word8 deriving (Show,Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) type Signature = Bytes 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 :: Bytes } deriving (Show, Eq) newtype ClientRandom = ClientRandom { unClientRandom :: Bytes } deriving (Show, Eq) newtype Session = Session (Maybe SessionID) deriving (Show, Eq) type FinishedData = Bytes type ExtensionID = Word16 data ExtensionRaw = ExtensionRaw ExtensionID Bytes deriving (Eq) instance Show ExtensionRaw where show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs ++ "" constrRandom32 :: (Bytes -> a) -> Bytes -> Maybe a constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing serverRandom :: Bytes -> Maybe ServerRandom serverRandom l = constrRandom32 ServerRandom l clientRandom :: Bytes -> Maybe ClientRandom clientRandom l = constrRandom32 ClientRandom l 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 | UnsupportedExtension | CertificateUnobtainable | UnrecognizedName | BadCertificateStatusResponse | BadCertificateHashValue 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 | HandshakeType_NPN -- Next Protocol Negotiation extension deriving (Show,Eq) newtype BigNum = BigNum Bytes 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 ECDHParams ECDHPublic 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 Bytes -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. | SKX_Unknown Bytes deriving (Show,Eq) data ClientKeyXchgAlgorithmData = CKX_RSA Bytes | CKX_DH DHPublic | CKX_ECDH ECDHPublic 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 | HsNextProtocolNegotiation Bytes -- NPN extension 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 typeOfHandshake (HsNextProtocolNegotiation {}) = HandshakeType_NPN numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) numericalVer SSL3 = (3, 0) numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3) 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 _ = 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 valOfType HandshakeType_NPN = 67 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 67 = Just HandshakeType_NPN 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 UnsupportedExtension = 110 valOfType CertificateUnobtainable = 111 valOfType UnrecognizedName = 112 valOfType BadCertificateStatusResponse = 113 valOfType BadCertificateHashValue = 114 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 110 = Just UnsupportedExtension valToType 111 = Just CertificateUnobtainable valToType 112 = Just UnrecognizedName valToType 113 = Just BadCertificateStatusResponse valToType 114 = Just BadCertificateHashValue valToType _ = Nothing instance TypeValuable CertificateType where valOfType CertificateType_RSA_Sign = 1 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_Unknown i) = i 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 i = Just (CertificateType_Unknown i) 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 (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 i = Just (HashOther i) instance TypeValuable SignatureAlgorithm where valOfType SignatureAnonymous = 0 valOfType SignatureRSA = 1 valOfType SignatureDSS = 2 valOfType SignatureECDSA = 3 valOfType (SignatureOther i) = i valToType 0 = Just SignatureAnonymous valToType 1 = Just SignatureRSA valToType 2 = Just SignatureDSS valToType 3 = Just SignatureECDSA valToType i = Just (SignatureOther i) tls-1.3.8/Network/TLS/Types.hs0000644000000000000000000000222712715016070014250 0ustar0000000000000000-- | -- Module : Network.TLS.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Types ( Version(..) , SessionID , SessionData(..) , CipherID , CompressionID , Role(..) , invertRole , Direction(..) ) where import Data.ByteString (ByteString) import Data.Word -- | Versions known to TLS -- -- SSL2 is just defined, but this version is and will not be supported. data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord, Bounded) -- | A session ID type SessionID = ByteString -- | Session data to resume data SessionData = SessionData { sessionVersion :: Version , sessionCipher :: CipherID , sessionSecret :: ByteString } 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 tls-1.3.8/Network/TLS/Util.hs0000644000000000000000000000502312715016070014056 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Util ( sub , takelast , partition3 , partition6 , fromJust , and' , (&&!) , bytesEq , fmapEither , catchException ) where import Data.List (foldl') import Network.TLS.Imports (Bytes) import qualified Data.ByteString as B import Control.Exception (SomeException) import Control.Concurrent.Async sub :: Bytes -> Int -> Int -> Maybe Bytes sub b offset len | B.length b < offset + len = Nothing | otherwise = Just $ B.take len $ snd $ B.splitAt offset b takelast :: Int -> Bytes -> Maybe Bytes takelast i b | B.length b >= i = sub b (B.length b - i) i | otherwise = Nothing partition3 :: Bytes -> (Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes) 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 :: Bytes -> (Int,Int,Int,Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes, Bytes) 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 and and' :: [Bool] -> Bool and' l = foldl' (&&!) True l -- | 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 :: Bytes -> Bytes -> Bool bytesEq b1 b2 | B.length b1 /= B.length b2 = False | otherwise = and' $ B.zipWith (==) b1 b2 fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f e = case e of Left l -> Left l Right r -> Right (f r) catchException :: IO a -> (SomeException -> IO a) -> IO a catchException action handler = withAsync action waitCatch >>= either handler return tls-1.3.8/Network/TLS/Wire.hs0000644000000000000000000001152312715016070014051 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 , getBytes , getOpaque8 , getOpaque16 , getOpaque24 , getInteger16 , getBigNum16 , getList , processBytes , isEmpty , Put , runPut , putWord8 , putWords8 , putWord16 , putWords16 , putWord24 , 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 Control.Applicative ((<$>)) import Control.Monad import qualified Data.ByteString as B import Data.Word import Data.Bits import Network.TLS.Struct import Network.TLS.Util.Serialization type GetContinuation a = Bytes -> GetResult a data GetResult a = GotError TLSError | GotPartial (GetContinuation a) | GotSuccess a | GotSuccessRemaining a Bytes runGet :: String -> Get a -> Bytes -> 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 -> Bytes -> 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 -> Bytes -> Maybe a runGetMaybe f = either (const Nothing) Just . G.runGet f tryGet :: Get a -> Bytes -> 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 getOpaque8 :: Get Bytes getOpaque8 = getWord8 >>= getBytes . fromIntegral getOpaque16 :: Get Bytes getOpaque16 = getWord16 >>= getBytes . fromIntegral getOpaque24 :: Get Bytes 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) -> liftM ((:) 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 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 :: Bytes -> Put putBytes = putByteString putOpaque8 :: Bytes -> Put putOpaque8 b = putWord8 (fromIntegral $ B.length b) >> putBytes b putOpaque16 :: Bytes -> Put putOpaque16 b = putWord16 (fromIntegral $ B.length b) >> putBytes b putOpaque24 :: Bytes -> 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 -> Bytes encodeWord16 = runPut . putWord16 encodeWord32 :: Word32 -> Bytes encodeWord32 = runPut . putWord32 encodeWord64 :: Word64 -> Bytes encodeWord64 = runPut . putWord64be tls-1.3.8/Network/TLS/X509.hs0000644000000000000000000000371312715016070013612 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 ) 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 | 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 | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) tls-1.3.8/Network/TLS/Context/0000755000000000000000000000000012715016070014231 5ustar0000000000000000tls-1.3.8/Network/TLS/Context/Internal.hs0000644000000000000000000002016512715016070016345 0ustar0000000000000000-- | -- 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(..) , 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 , usingState , usingState_ , runTxState , runRxState , usingHState , getHState , getStateRNG ) where import Network.TLS.Backend import Network.TLS.Extension import Network.TLS.Cipher import Network.TLS.Struct 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 qualified Data.ByteString as B import Control.Concurrent.MVar import Control.Monad.State 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 Bytes , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom } 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 , ctxCiphers :: [Cipher] -- ^ prepared list of allowed ciphers according to parameters , ctxState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. , ctxEstablished_ :: IORef Bool -- ^ 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 () , 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. } 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 contextFlush :: Context -> IO () contextFlush = backendFlush . 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, cr, sr) = case hstate of Just st -> (hstMasterSecret st, Just (hstClientRandom st), hstServerRandom st) Nothing -> (Nothing, Nothing, Nothing) (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st) case (ver, cipher) of (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr _ -> return Nothing contextSend :: Context -> Bytes -> IO () contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b contextRecv :: Context -> Int -> IO Bytes 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 Bool 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 f = modifyIORef (ctxHooks ctx) f setEstablished :: Context -> Bool -> IO () setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v 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 :: Context -> HandshakeM a -> IO a usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> case mst of Nothing -> throwCore $ Error_Misc "missing handshake" Just st -> return $ swap (Just `fmap` runHandshake st f) getHState :: Context -> IO (Maybe HandshakeState) getHState ctx = liftIO $ readMVar (ctxHandshake ctx) runTxState :: Context -> RecordM a -> IO (Either TLSError a) runTxState ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) modifyMVar (ctxTxState ctx) $ \st -> case runRecordM f ver 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 modifyMVar (ctxRxState ctx) $ \st -> case runRecordM f ver st of Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) getStateRNG :: Context -> Int -> IO Bytes 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) tls-1.3.8/Network/TLS/Crypto/0000755000000000000000000000000012715016070014065 5ustar0000000000000000tls-1.3.8/Network/TLS/Crypto/DH.hs0000644000000000000000000000260612715016070014720 0ustar0000000000000000module Network.TLS.Crypto.DH ( -- * DH types DHParams , DHPublic , DHPrivate -- * DH methods , dhPublic , dhPrivate , dhParams , dhParamsGetP , dhParamsGetG , dhGenerateKeyPair , dhGetShared , dhUnwrap , dhUnwrapPublic ) where import qualified Crypto.PubKey.DH as DH import Crypto.Number.Basic (numBits) 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.generatePublic params priv return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey dhGetShared params priv pub = DH.getShared params priv pub 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 dhUnwrapPublic :: DHPublic -> Integer dhUnwrapPublic (DH.PublicNumber y) = y tls-1.3.8/Network/TLS/Crypto/ECDH.hs0000644000000000000000000000462012715016070015126 0ustar0000000000000000module Network.TLS.Crypto.ECDH ( -- * ECDH types ECDHParams(..) , ECDHPublic , ECDHPrivate(..) -- * ECDH methods , ecdhPublic , ecdhPrivate , ecdhParams , ecdhGenerateKeyPair , ecdhGetShared , ecdhUnwrap , ecdhUnwrapPublic ) where import Network.TLS.Util.Serialization (lengthBytes) import Network.TLS.Extension.EC import qualified Crypto.PubKey.ECC.DH as ECDH import qualified Crypto.PubKey.ECC.Types as ECDH import qualified Crypto.PubKey.ECC.Prim as ECC (isPointValid) import Network.TLS.RNG import Data.Word (Word16) data ECDHPublic = ECDHPublic ECDH.PublicPoint Int {- byte size -} deriving (Show,Eq) newtype ECDHPrivate = ECDHPrivate ECDH.PrivateNumber deriving (Show,Eq) data ECDHParams = ECDHParams ECDH.Curve ECDH.CurveName deriving (Show,Eq) type ECDHKey = ECDH.SharedKey ecdhPublic :: Integer -> Integer -> Int -> ECDHPublic ecdhPublic x y siz = ECDHPublic (ECDH.Point x y) siz ecdhPrivate :: Integer -> ECDHPrivate ecdhPrivate = ECDHPrivate ecdhParams :: Word16 -> ECDHParams ecdhParams w16 = ECDHParams curve name where Just name = toCurveName w16 -- FIXME curve = ECDH.getCurveByName name ecdhGenerateKeyPair :: MonadRandom r => ECDHParams -> r (ECDHPrivate, ECDHPublic) ecdhGenerateKeyPair (ECDHParams curve _) = do priv <- ECDH.generatePrivate curve let siz = pointSize curve point = ECDH.calculatePublic curve priv pub = ECDHPublic point siz return (ECDHPrivate priv, pub) ecdhGetShared :: ECDHParams -> ECDHPrivate -> ECDHPublic -> Maybe ECDHKey ecdhGetShared (ECDHParams curve _) (ECDHPrivate priv) (ECDHPublic point _) | ECC.isPointValid curve point = Just $ ECDH.getShared curve priv point | otherwise = Nothing -- for server key exchange ecdhUnwrap :: ECDHParams -> ECDHPublic -> (Word16,Integer,Integer,Int) ecdhUnwrap (ECDHParams _ name) point = (w16,x,y,siz) where w16 = case fromCurveName name of Just w -> w Nothing -> error "ecdhUnwrap" (x,y,siz) = ecdhUnwrapPublic point -- for client key exchange ecdhUnwrapPublic :: ECDHPublic -> (Integer,Integer,Int) ecdhUnwrapPublic (ECDHPublic (ECDH.Point x y) siz) = (x,y,siz) ecdhUnwrapPublic _ = error "ecdhUnwrapPublic" pointSize :: ECDH.Curve -> Int pointSize (ECDH.CurveFP curve) = lengthBytes $ ECDH.ecc_p curve pointSize _ = error "pointSize" -- FIXME tls-1.3.8/Network/TLS/Extension/0000755000000000000000000000000012715016070014561 5ustar0000000000000000tls-1.3.8/Network/TLS/Extension/EC.hs0000644000000000000000000000413412715016070015406 0ustar0000000000000000module Network.TLS.Extension.EC ( CurveName(..) , toCurveName , fromCurveName ) where import Crypto.PubKey.ECC.Types (CurveName(..)) import Data.Word (Word16) toCurveName :: Word16 -> Maybe CurveName toCurveName 1 = Just SEC_t163k1 toCurveName 2 = Just SEC_t163r1 toCurveName 3 = Just SEC_t163r2 toCurveName 4 = Just SEC_t193r1 toCurveName 5 = Just SEC_t193r2 toCurveName 6 = Just SEC_t233k1 toCurveName 7 = Just SEC_t233r1 toCurveName 8 = Just SEC_t239k1 toCurveName 9 = Just SEC_t283k1 toCurveName 10 = Just SEC_t283r1 toCurveName 11 = Just SEC_t409k1 toCurveName 12 = Just SEC_t409r1 toCurveName 13 = Just SEC_t571k1 toCurveName 14 = Just SEC_t571r1 toCurveName 15 = Just SEC_p160k1 toCurveName 16 = Just SEC_p160r1 toCurveName 17 = Just SEC_p160r2 toCurveName 18 = Just SEC_p192k1 toCurveName 19 = Just SEC_p192r1 toCurveName 20 = Just SEC_p224k1 toCurveName 21 = Just SEC_p224r1 toCurveName 22 = Just SEC_p256k1 toCurveName 23 = Just SEC_p256r1 toCurveName 24 = Just SEC_p384r1 toCurveName 25 = Just SEC_p521r1 --toCurveName 26 = Just Brainpool_P256r1 --toCurveName 27 = Just Brainpool_P384r1 --toCurveName 28 = Just Brainpool_P512r1 toCurveName _ = Nothing fromCurveName :: CurveName -> Maybe Word16 fromCurveName SEC_t163k1 = Just 1 fromCurveName SEC_t163r1 = Just 2 fromCurveName SEC_t163r2 = Just 3 fromCurveName SEC_t193r1 = Just 4 fromCurveName SEC_t193r2 = Just 5 fromCurveName SEC_t233k1 = Just 6 fromCurveName SEC_t233r1 = Just 7 fromCurveName SEC_t239k1 = Just 8 fromCurveName SEC_t283k1 = Just 9 fromCurveName SEC_t283r1 = Just 10 fromCurveName SEC_t409k1 = Just 11 fromCurveName SEC_t409r1 = Just 12 fromCurveName SEC_t571k1 = Just 13 fromCurveName SEC_t571r1 = Just 14 fromCurveName SEC_p160k1 = Just 15 fromCurveName SEC_p160r1 = Just 16 fromCurveName SEC_p160r2 = Just 17 fromCurveName SEC_p192k1 = Just 18 fromCurveName SEC_p192r1 = Just 19 fromCurveName SEC_p224k1 = Just 20 fromCurveName SEC_p224r1 = Just 21 fromCurveName SEC_p256k1 = Just 22 fromCurveName SEC_p256r1 = Just 23 fromCurveName SEC_p384r1 = Just 24 fromCurveName SEC_p521r1 = Just 25 fromCurveName _ = Nothing tls-1.3.8/Network/TLS/Extra/0000755000000000000000000000000012715016070013670 5ustar0000000000000000tls-1.3.8/Network/TLS/Extra/Cipher.hs0000644000000000000000000005120412715016070015440 0ustar0000000000000000-- | -- Module : Network.TLS.Extra.Cipher -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} module Network.TLS.Extra.Cipher ( -- * cipher suite ciphersuite_all , ciphersuite_medium , ciphersuite_strong , ciphersuite_unencrypted , ciphersuite_dhe_rsa , ciphersuite_dhe_dss -- * individual ciphers , cipher_null_SHA1 , cipher_null_MD5 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_AES128_SHA256 , cipher_AES256_SHA256 , cipher_RSA_3DES_EDE_CBC_SHA1 , 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_DSS_RC4_SHA1 , cipher_DHE_RSA_AES128GCM_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_ECDSA_AES128GCM_SHA256 ) where import qualified Data.ByteString as B import Network.TLS (Version(..)) import Network.TLS.Cipher import Data.Tuple (swap) import Crypto.Cipher.AES import qualified Crypto.Cipher.RC4 as RC4 import Crypto.Cipher.TripleDES import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error 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)) 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) where simpleDecrypt aeadIni header input = (output, tag) where aead = aeadAppendHeader aeadIni header (output, aeadFinal) = aeadDecrypt aead input tag = aeadFinalize aeadFinal 16 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) where simpleDecrypt aeadIni header input = (output, tag) where aead = aeadAppendHeader aeadIni header (output, aeadFinal) = aeadDecrypt aead input tag = aeadFinalize aeadFinal 16 noFail :: CryptoFailable a -> a noFail = throwCryptoError makeIV_ :: BlockCipher a => B.ByteString -> IV a makeIV_ = maybe (error "makeIV_") id . 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 = maybe (error "tripledes cipher iv internal error") id $ 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')) -- | all encrypted ciphers supported ordered from strong to weak. -- this choice of ciphersuite should satisfy most normal need ciphersuite_all :: [Cipher] ciphersuite_all = [ cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_ECDHE_RSA_AES256CBC_SHA , cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1 , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 , cipher_AES128_SHA256, cipher_AES256_SHA256 , cipher_AES128_SHA1, cipher_AES256_SHA1 , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_DHE_RSA_AES128GCM_SHA256 ] -- | list of medium ciphers. ciphersuite_medium :: [Cipher] ciphersuite_medium = [cipher_RC4_128_MD5, cipher_RC4_128_SHA1, cipher_AES128_SHA1, cipher_AES256_SHA1] -- | the strongest ciphers supported. ciphersuite_strong :: [Cipher] ciphersuite_strong = [ cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_ECDHE_RSA_AES256CBC_SHA , cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256_SHA256 , cipher_AES256_SHA256 , cipher_AES256_SHA1 ] -- | DHE-RSA cipher suite ciphersuite_dhe_rsa :: [Cipher] ciphersuite_dhe_rsa = [cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1 , cipher_DHE_RSA_AES128GCM_SHA256] 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_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_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_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 } -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher { cipherID = 0x1 , cipherName = "RSA-null-MD5" , cipherBulk = bulk_null , cipherHash = MD5 , 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 = 0x2 , cipherName = "RSA-null-SHA1" , cipherBulk = bulk_null , cipherHash = SHA1 , 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 = 0x04 , cipherName = "RSA-rc4-128-md5" , cipherBulk = bulk_rc4 , cipherHash = MD5 , 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 = 0x05 , cipherName = "RSA-rc4-128-sha1" , cipherBulk = bulk_rc4 , cipherHash = SHA1 , 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 = 0x2f , cipherName = "RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , 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 = 0x32 , cipherName = "DHE-DSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , 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 = 0x33 , cipherName = "DHE-RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , 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 = 0x35 , cipherName = "RSA-AES256-SHA1" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , 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 = 0x38 , 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 = 0x39 , 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 = 0x3c , cipherName = "RSA-AES128-SHA256" , cipherBulk = bulk_aes128 , cipherHash = 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 = 0x3d , cipherName = "RSA-AES256-SHA256" , cipherBulk = bulk_aes256 , cipherHash = SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } cipher_DHE_DSS_RC4_SHA1 :: Cipher cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 { cipherID = 0x66 , 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 = 0x67 , cipherName = "DHE-RSA-AES128-SHA256" , cipherHash = SHA256 , cipherMinVer = Just TLS12 } cipher_DHE_RSA_AES256_SHA256 :: Cipher cipher_DHE_RSA_AES256_SHA256 = cipher_DHE_RSA_AES128_SHA256 { cipherID = 0x6b , cipherName = "DHE-RSA-AES256-SHA256" , cipherBulk = bulk_aes256 } -- | 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 = 0x0a , cipherName = "RSA-3DES-EDE-CBC-SHA1" , cipherBulk = bulk_tripledes_ede , cipherHash = SHA1 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher cipher_DHE_RSA_AES128GCM_SHA256 = Cipher { cipherID = 0x9e , cipherName = "DHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA = Cipher { cipherID = 0xc013 , cipherName = "ECDHE-RSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , 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 , 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 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA384 = Cipher { cipherID = 0xc027 , cipherName = "ECDHE-RSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher { cipherID = 0xc02b , cipherName = "ECDHE-ECDSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , 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 , 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-SHA256" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5289 } {- TLS 1.0 ciphers definition CipherSuite TLS_NULL_WITH_NULL_NULL = { 0x00,0x00 }; CipherSuite TLS_RSA_WITH_NULL_MD5 = { 0x00,0x01 }; CipherSuite TLS_RSA_WITH_NULL_SHA = { 0x00,0x02 }; CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x03 }; CipherSuite TLS_RSA_WITH_RC4_128_MD5 = { 0x00,0x04 }; CipherSuite TLS_RSA_WITH_RC4_128_SHA = { 0x00,0x05 }; CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5 = { 0x00,0x06 }; CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA = { 0x00,0x07 }; CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x08 }; CipherSuite TLS_RSA_WITH_DES_CBC_SHA = { 0x00,0x09 }; CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0A }; CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0B }; CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA = { 0x00,0x0C }; CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0D }; CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0E }; CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA = { 0x00,0x0F }; CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x10 }; CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 }; CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA = { 0x00,0x12 }; CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x13 }; CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 }; CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA = { 0x00,0x15 }; CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x16 }; CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x17 }; CipherSuite TLS_DH_anon_WITH_RC4_128_MD5 = { 0x00,0x18 }; CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 }; CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA = { 0x00,0x1A }; CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA = { 0x00,0x1B }; TLS-DHE-RSA-WITH-AES-128-CBC-SHA {0x00,0x33} TLS-DHE-RSA-WITH-AES-256-CBC-SHA {0x00,0x39} TLS-DHE-RSA-WITH-AES-128-CBC-SHA256 {0x00,0x67} TLS-DHE-RSA-WITH-AES-256-CBC-SHA256 {0x00,0x6B} TLS-DHE-RSA-WITH-AES-128-GCM-SHA256 {0x00,0x9E} TLS-DHE-RSA-WITH-AES-256-GCM-SHA384 {0x00,0x9F} TLS-DHE-RSA-WITH-CAMELLIA-128-CBC-SHA {0x00,0x45} TLS-DHE-RSA-WITH-CAMELLIA-256-CBC-SHA {0x00,0x88} TLS-DHE-RSA-WITH-CAMELLIA-128-CBC-SHA256 {0x00,0xBE} TLS-DHE-RSA-WITH-CAMELLIA-256-CBC-SHA256 {0x00,0xC4} TLS-DHE-RSA-WITH-CAMELLIA-128-GCM-SHA256 {0x00,0x7C} TLS-DHE-RSA-WITH-CAMELLIA-256-GCM-SHA256 {0x00,0x7D} TLS-DHE-RSA-WITH-3DES-EDE-CBC-SHA {0x00,0x16} TLS-DHE-RSA-WITH-DES-CBC-SHA {0x00,0x15} TLS-ECDHE-RSA-WITH-AES-128-CBC-SHA {0xC0,0x13} TLS-ECDHE-RSA-WITH-AES-256-CBC-SHA {0xC0,0x14} TLS-ECDHE-RSA-WITH-AES-128-CBC-SHA256 {0xC0,0x27} TLS-ECDHE-RSA-WITH-AES-256-CBC-SHA384 {0xC0,0x28} TLS-ECDHE-RSA-WITH-AES-128-GCM-SHA256 {0xC0,0x2F} TLS-ECDHE-RSA-WITH-AES-256-GCM-SHA384 {0xC0,0x30} TLS-ECDHE-RSA-WITH-CAMELLIA-128-CBC-SHA256 {0xC0,0x76} TLS-ECDHE-RSA-WITH-CAMELLIA-256-CBC-SHA384 {0xC0,0x77} TLS-ECDHE-RSA-WITH-CAMELLIA-128-GCM-SHA256 {0xC0,0x8A} TLS-ECDHE-RSA-WITH-CAMELLIA-256-GCM-SHA384 {0xC0,0x8B} TLS-ECDHE-RSA-WITH-3DES-EDE-CBC-SHA {0xC0,0x12} TLS-ECDHE-RSA-WITH-RC4-128-SHA {0xC0,0x11} TLS-ECDHE-RSA-WITH-NULL-SHA {0xC0,0x10} TLS-PSK-WITH-RC4-128-SHA {0x00,0x8A} TLS-PSK-WITH-3DES-EDE-CBC-SHA {0x00,0x8B} TLS-PSK-WITH-AES-128-CBC-SHA {0x00,0x8C} TLS-PSK-WITH-AES-256-CBC-SHA {0x00,0x8D} TLS-PSK-WITH-AES-128-CBC-SHA256 {0x00,0xAE} TLS-PSK-WITH-AES-256-CBC-SHA384 {0x00,0xAF} TLS-PSK-WITH-AES-128-GCM-SHA256 {0x00,0xA8} TLS-PSK-WITH-AES-256-GCM-SHA384 {0x00,0xA9} TLS-PSK-WITH-CAMELLIA-128-CBC-SHA256 {0xC0,0x94} TLS-PSK-WITH-CAMELLIA-256-CBC-SHA384 {0xC0,0x95} TLS-PSK-WITH-CAMELLIA-128-GCM-SHA256 {0xC0,0x8D} TLS-PSK-WITH-CAMELLIA-256-GCM-SHA384 {0xC0,0x8F} TLS-PSK-WITH-NULL-SHA {0x00,0x2C} TLS-PSK-WITH-NULL-SHA256 {0x00,0xB4} TLS-PSK-WITH-NULL-SHA384 {0x00,0xB5} best ciphers suite description: -} tls-1.3.8/Network/TLS/Handshake/0000755000000000000000000000000012715016070014473 5ustar0000000000000000tls-1.3.8/Network/TLS/Handshake/Certificate.hs0000644000000000000000000000237712715016070017262 0ustar0000000000000000-- | -- Module : Network.TLS.Handshake.Certificate -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Certificate ( certificateRejected , rejectOnException ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509 import Control.Monad.State import Control.Exception (SomeException) -- 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 (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) rejectOnException :: SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e tls-1.3.8/Network/TLS/Handshake/Client.hs0000644000000000000000000005367312715016070016263 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Client -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Client ( handshakeClient , handshakeClientWith ) where import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Packet import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.IO import Network.TLS.Imports import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Measurement import Network.TLS.Wire (encodeWord16) import Network.TLS.Util (bytesEq, catchException) import Network.TLS.Types import Network.TLS.X509 import Data.Maybe import Data.List (find) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Control.Monad.State import Control.Exception (SomeException) import Network.TLS.Handshake.Common import Network.TLS.Handshake.Process import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Key import Network.TLS.Handshake.State 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 updateMeasure ctx incrementNbHandshakes sentExtensions <- sendClientHello recvServerHello sentExtensions sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish sendMaybeNPN ctx ClientRole else do sendClientData cparams ctx sendChangeCipherAndFinish sendMaybeNPN ctx ClientRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where ciphers = ctxCiphers ctx compressions = supportedCompressions $ ctxSupported ctx getExtensions = sequence [sniExtension ,secureReneg ,npnExtention ,alpnExtension ,curveExtension ,ecPointExtension --,sessionTicketExtension ,signatureAlgExtension -- ,heartbeatExtension ] 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 npnExtention = if isJust $ onNPNServerSuggest $ clientHooks cparams then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] 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 sniExtension = if clientUseServerNameIndication cparams then return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName $ fst $ clientServerIdentification cparams] else return Nothing curveExtension = return $ Just $ toExtensionRaw $ EllipticCurvesSupported availableEllipticCurves 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 sendClientHello = do crand <- getStateRNG ctx 32 >>= return . ClientRandom let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams highestVer = maximum $ supportedVersions $ ctxSupported ctx extensions <- catMaybes <$> getExtensions startHandshake ctx highestVer crand usingState_ ctx $ setVersionIfUnset highestVer sendPacket ctx $ Handshake [ ClientHello highestVer crand clientSession (map cipherID ciphers) (map compressionID compressions) extensions Nothing ] return $ map (\(ExtensionRaw i _) -> i) extensions sendMaybeNPN = do suggest <- usingState_ ctx $ getServerNextProtocolSuggest case (onNPNServerSuggest $ clientHooks cparams, suggest) of -- client offered, server picked up. send NPN handshake. (Just io, Just protos) -> do proto <- liftIO $ io protos sendPacket ctx (Handshake [HsNextProtocolNegotiation proto]) usingState_ ctx $ setNegotiatedProtocol proto -- client offered, server didn't pick up. do nothing. (Just _, Nothing) -> return () -- client didn't offer. do nothing. (Nothing, _) -> return () recvServerHello sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs Alert a -> case a of [(AlertLevel_Warning, UnrecognizedName)] -> if clientUseServerNameIndication cparams then return recvState else throwAlert a _ -> throwAlert a _ -> fail ("unexepected type received. expecting handshake and got: " ++ show p) throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) -- | send client Data after receiving all server data (hello/certificates/key). -- -- -> [certificate] -- -> client key exchange -- -> [cert verify] sendClientData :: ClientParams -> Context -> IO () sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify where -- When the server requests a client certificate, we -- fetch a certificate chain from the callback in the -- client parameters and send it to the server. -- Additionally, we store the private key associated -- with the first certificate in the chain for later -- use. -- sendCertificate = do certRequested <- usingHState ctx getClientCertRequest case certRequested of Nothing -> return () Just req -> do certChain <- liftIO $ (onCertificateRequest $ clientHooks cparams) req `catchException` throwMiscErrorOnException "certificate request callback failed" usingHState ctx $ setClientCertSent False case certChain of Nothing -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])] Just (CertificateChain [], _) -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])] Just (cc@(CertificateChain (c:_)), pk) -> do case certPubKey $ getCertificate c of PubKeyRSA _ -> return () _ -> throwCore $ Error_Protocol ("no supported certificate type", True, HandshakeFailure) usingHState ctx $ setPrivateKey pk usingHState ctx $ setClientCertSent True sendPacket ctx $ Handshake [Certificates cc] sendClientKeyXchg = do cipher <- usingHState ctx getPendingCipher ckx <- case cipherKeyExchange cipher of CipherKeyExchange_RSA -> do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 let premaster = encodePreMasterSecret clientVersion prerand usingHState ctx $ 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 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] where getCKX_DHE = do xver <- usingState_ ctx getVersion serverParams <- fromJust <$> usingHState ctx (gets hstServerDHParams) (clientDHPriv, clientDHPub) <- generateDHE ctx (serverDHParamsToParams serverParams) let premaster = dhGetShared (serverDHParamsToParams serverParams) clientDHPriv (serverDHParamsToPublic serverParams) usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster return $ CKX_DH clientDHPub getCKX_ECDHE = do xver <- usingState_ ctx getVersion (ServerECDHParams ecdhparams serverECDHPub) <- fromJust <$> usingHState ctx (gets hstServerECDHParams) (clientECDHPriv, clientECDHPub) <- generateECDHE ctx ecdhparams case ecdhGetShared ecdhparams clientECDHPriv serverECDHPub of Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) Just premaster -> do usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster return $ CKX_ECDH clientECDHPub -- 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 usedVersion <- usingState_ ctx getVersion -- Only send a certificate verify message when we -- have sent a non-empty list of certificates. -- certSent <- usingHState ctx $ getClientCertSent case certSent of True -> do malg <- case usedVersion of TLS12 -> do Just (_, Just hashSigs, _) <- usingHState ctx $ getClientCertRequest let suppHashSigs = supportedHashSignatures $ ctxSupported ctx hashSigs' = filter (\ a -> a `elem` hashSigs) suppHashSigs when (null hashSigs') $ throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure) return $ Just $ head hashSigs' _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- certificateVerifyCreate ctx usedVersion malg msgs sendPacket ctx $ Handshake [CertVerify sigDig] _ -> return () processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw 0xff01 content) = 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) return () 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) process NPN extension -- 6) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher -- onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) (supportedVersions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server version " ++ show rver ++ " is not supported", True, ProtocolVersion) Just _ -> return () -- find the compression and cipher methods that the server want to use. cipherAlg <- case find ((==) cipher . cipherID) (ctxCiphers ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure) Just alg -> return alg compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, HandshakeFailure) 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. when (not $ null $ filter (not . flip elem sentExts . (\(ExtensionRaw i _) -> i)) 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 usingState_ ctx $ do setSession serverSession (isJust resumingSession) mapM_ processServerExtension exts setVersion rver usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of Just protos -> when (elem proto protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return () _ -> return () case extensionDecode False `fmap` (extensionLookup extensionID_NextProtocolNegotiation exts) of Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do alpnDone <- getExtensionALPN unless alpnDone $ do setExtensionNPN True setServerNextProtocolSuggest protos _ -> return () case resumingSession of Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) Just sessionData -> do usingHState ctx (setMasterSecret rver ClientRole $ sessionSecret sessionData) return $ RecvStateNext expectChangeCipher onServerHello _ _ _ p = unexpected (show p) (Just "server hello") processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do -- run certificate recv hook ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs) -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason return $ RecvStateHandshake (processServerKeyExchange ctx) where shared = clientShared cparams checkCert = (onServerCertificate $ clientHooks cparams) (sharedCAStore shared) (sharedValidationCache shared) (clientServerIdentification cparams) 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) -> do doDHESignature dhparams signature SignatureRSA (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> do doDHESignature dhparams signature SignatureDSS (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> do doECDHESignature ecdhparams signature SignatureRSA (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> do doECDHESignature ecdhparams signature SignatureECDSA (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 signatureType = do -- TODO verify DHParams verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for dhparams " ++ show dhparams, True, HandshakeFailure) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature signatureType = do -- TODO verify DHParams verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for ecdhparams", True, HandshakeFailure) usingHState ctx $ setServerECDHParams ecdhparams processServerKeyExchange ctx p = processCertificateRequest ctx p processCertificateRequest :: Context -> Handshake -> IO (RecvState IO) processCertificateRequest ctx (CertRequest cTypes sigAlgs dNames) = do -- When the server requests a client -- certificate, we simply store the -- information for later. -- usingHState ctx $ setClientCertRequest (cTypes, sigAlgs, dNames) return $ RecvStateHandshake (processServerHelloDone ctx) processCertificateRequest ctx p = processServerHelloDone ctx p processServerHelloDone :: Context -> Handshake -> IO (RecvState m) processServerHelloDone _ ServerHelloDone = return RecvStateDone processServerHelloDone _ p = unexpected (show p) (Just "server hello data") tls-1.3.8/Network/TLS/Handshake/Common.hs0000644000000000000000000001272712715016070016270 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Network.TLS.Handshake.Common ( handshakeFailed , errorToAlert , unexpected , newSession , handshakeTerminate -- * sending packets , sendChangeCipherAndFinish -- * receiving packets , recvChangeCipherAndFinish , RecvState(..) , runRecvState , recvPacketHandshake , onRecvStateHandshake , extensionLookup ) where import Control.Concurrent.MVar import Network.TLS.Parameters import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct import Network.TLS.IO import Network.TLS.State hiding (getNegotiatedProtocol) 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.Util import Data.List (find) import Data.ByteString.Char8 () import Control.Monad.State import Control.Exception (throwIO) handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err errorToAlert :: TLSError -> Packet errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] unexpected :: String -> Maybe [Char] -> IO a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session newSession ctx | supportedSession $ ctxSupported ctx = getStateRNG ctx 32 >>= return . Session . Just | 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 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 } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. setEstablished ctx True return () sendChangeCipherAndFinish :: IO () -- ^ message possibly sent between ChangeCipherSpec and Finished. -> Context -> Role -> IO () sendChangeCipherAndFinish betweenCall ctx role = do sendPacket ctx ChangeCipherSpec betweenCall 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 -> fail ("unexpected type received. expecting handshake and got: " ++ show x) 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 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 getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do ver <- usingState_ ctx getVersion mms <- usingHState ctx (gets hstMasterSecret) tx <- liftIO $ readMVar (ctxTxState ctx) case mms of Nothing -> return Nothing Just ms -> return $ Just $ SessionData { sessionVersion = ver , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx , sessionSecret = ms } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe Bytes extensionLookup toFind = fmap (\(ExtensionRaw _ content) -> content) . find (\(ExtensionRaw eid _) -> eid == toFind) tls-1.3.8/Network/TLS/Handshake/Key.hs0000644000000000000000000000444712715016070015570 0ustar0000000000000000-- | -- 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 , signRSA , decryptRSA , verifyRSA , generateDHE , generateECDHE ) where import Data.ByteString (ByteString) 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 {- 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 -> fail ("rsa encrypt failed: " ++ show err) Right econtent -> return econtent signRSA :: Context -> Role -> Hash -> ByteString -> IO ByteString signRSA ctx _ hsh content = do privateKey <- usingHState ctx getLocalPrivateKey usingState_ ctx $ do r <- withRNG $ kxSign privateKey hsh content case r of Left err -> fail ("rsa sign failed: " ++ show err) Right econtent -> return econtent decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) decryptRSA ctx econtent = do privateKey <- usingHState ctx getLocalPrivateKey usingState_ ctx $ do ver <- getVersion let cipher = if ver < TLS10 then econtent else B.drop 2 econtent withRNG $ kxDecrypt privateKey cipher verifyRSA :: Context -> Role -> Hash -> ByteString -> ByteString -> IO Bool verifyRSA ctx _ hsh econtent sign = do publicKey <- usingHState ctx getRemotePublicKey return $ kxVerify publicKey hsh econtent sign generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp generateECDHE :: Context -> ECDHParams -> IO (ECDHPrivate, ECDHPublic) generateECDHE ctx dhp = usingState_ ctx $ withRNG $ ecdhGenerateKeyPair dhp tls-1.3.8/Network/TLS/Handshake/Process.hs0000644000000000000000000001404712715016070016453 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 , startHandshake , getHandshakeDigest ) where import Control.Concurrent.MVar import Control.Monad.State (gets) import Control.Monad import Control.Monad.IO.Class (liftIO) import Network.TLS.Types (Role(..), invertRole) import Network.TLS.Util import Network.TLS.Packet import Network.TLS.ErrT import Network.TLS.Struct import Network.TLS.State import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Handshake.State import Network.TLS.Handshake.Key import Network.TLS.Extension import Network.TLS.Parameters 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 startHandshake ctx cver ran Certificates certs -> processCertificates role certs ClientKeyXchg content -> when (role == ServerRole) $ do processClientKeyXchg ctx content HsNextProtocolNegotiation selected_protocol -> when (role == ServerRole) $ usingState_ ctx $ setNegotiatedProtocol selected_protocol Finished fdata -> processClientFinished ctx fdata _ -> return () let encoded = encodeHandshake hs when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ usingHState ctx $ updateHandshakeDigest encoded 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 -- 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 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 processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext serverParams <- fromJust "server dh params" <$> usingHState ctx (gets hstServerDHParams) dhpriv <- fromJust "dh private" <$> usingHState ctx (gets hstDHPrivate) let premaster = dhGetShared (serverDHParamsToParams serverParams) dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster processClientKeyXchg ctx (CKX_ECDH clientECDHValue) = do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext (ServerECDHParams ecdhparams _) <- fromJust "server ecdh params" <$> usingHState ctx (gets hstServerECDHParams) ecdhpriv <- fromJust "ecdh private" <$> usingHState ctx (gets hstECDHPrivate) case ecdhGetShared ecdhparams ecdhpriv clientECDHValue of Nothing -> throwCore $ Error_Protocol("invalid client public key", True, HandshakeFailure) Just premaster -> usingHState ctx $ setMasterSecretFromPre rver role premaster processClientFinished :: Context -> FinishedData -> IO () processClientFinished ctx fdata = do (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc when (expected /= fdata) $ do throwCore $ Error_Protocol("bad record mac", True, BadRecordMac) usingState_ ctx $ updateVerifiedData ServerRole fdata return () startHandshake :: Context -> Version -> ClientRandom -> IO () startHandshake ctx ver crand = do -- FIXME check if handshake is already not null liftIO $ modifyMVar_ (ctxHandshake ctx) $ \hs -> case hs of Nothing -> return $ Just $ newEmptyHandshake ver crand Just _ -> return hs tls-1.3.8/Network/TLS/Handshake/Server.hs0000644000000000000000000005211212715016070016276 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Server ( handshakeServer , handshakeServerWith ) 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.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto.ECDH import Network.TLS.Extension import Network.TLS.Util (catchException, fromJust) import Network.TLS.IO import Network.TLS.Types import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Handshake.State import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key import Network.TLS.Measurement import Data.Maybe (isJust, listToMaybe, mapMaybe) import Data.List (intersect, sortBy) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Control.Monad.State import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Common import Network.TLS.Handshake.Certificate import Network.TLS.X509 -- 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 :: MonadIO m => ServerParams -> Context -> m () handshakeServer sparams ctx = liftIO $ do hss <- recvPacketHandshake ctx case hss of [ch] -> handshakeServerWith sparams ctx ch _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss) -- | 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 -- <- [NPN] -- <- finish -> finish -- -> change cipher <- change cipher -- -> finish <- finish -- handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientSession ciphers compressions exts _) = do -- rejecting client initiated renegotiation to prevent DOS. unless (supportedClientInitiatedRenegotiation (ctxSupported ctx)) $ do established <- ctxEstablished ctx eof <- ctxEOF ctx when (established && not eof) $ 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 when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) && (0x5600 `elem` ciphers) && clientVersion /= maxBound) $ throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback) chosenVersion <- case findHighestVersionFrom clientVersion (supportedVersions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion) Just v -> return v when (commonCipherIDs == []) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) when (null commonCompressions) $ throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) let serverName = case extensionDecode False `fmap` (extensionLookup extensionID_ServerName exts) of Just (Just (ServerName ns)) -> listToMaybe (mapMaybe toHostName ns) where toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing _ -> Nothing let ciphersFilteredVersion = filter (cipherAllowedForVersion chosenVersion) commonCiphers usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName let creds = extraCreds `mappend` (sharedCredentials $ ctxShared ctx) cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds CipherKeyExchange_DH_Anon -> return $ Nothing CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning SignatureDSS creds CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) resumeSessionData <- case clientSession of (Session (Just clientSessionId)) -> liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId (Session Nothing) -> return Nothing maybe (return ()) (usingState_ ctx . setClientSNI) serverName case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of Just (Just (ApplicationLayerProtocolNegotiation protos)) -> usingState_ ctx $ setClientALPNSuggest protos _ -> return () case extensionDecode False `fmap` (extensionLookup extensionID_EllipticCurves exts) of Just (Just (EllipticCurvesSupported es)) -> usingState_ ctx $ setClientEllipticCurveSuggest es _ -> return () -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed. case extensionDecode False `fmap` (extensionLookup extensionID_EcPointFormats exts) of Just (Just (EcPointFormatsSupported fs)) -> usingState_ ctx $ setClientEcPointFormatSuggest fs _ -> return () doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts where commonCipherIDs = intersect ciphers (map cipherID $ ctxCiphers ctx) commonCiphers = filter (flip elem commonCipherIDs . cipherID) (ctxCiphers ctx) commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions usedCompression = head commonCompressions handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) 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 (return ()) ctx ServerRole Just sessionData -> do usingState_ ctx (setSession clientSession True) serverhello <- makeServerHello clientSession sendPacket ctx $ Handshake [serverhello] usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData sendChangeCipherAndFinish (return ()) ctx ServerRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where clientRequestedNPN = isJust $ extensionLookup extensionID_NextProtocolNegotiation exts clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts applicationProtocol = do protos <- alpn if null protos then npn else return protos alpn | clientALPNSuggest = do suggest <- usingState_ ctx $ getClientALPNSuggest case (onALPNClientSuggest $ serverHooks sparams, suggest) of (Just io, Just protos) -> do proto <- liftIO $ io protos usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto return $ [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] (_, _) -> return [] | otherwise = return [] npn = do nextProtocols <- if clientRequestedNPN then liftIO $ onSuggestNextProtocols $ serverHooks sparams else return Nothing case nextProtocols of Just protos -> do usingState_ ctx $ do setExtensionNPN True setServerNextProtocolSuggest protos return [ ExtensionRaw extensionID_NextProtocolNegotiation (extensionEncode $ NextProtocolNegotiation protos) ] Nothing -> return [] --- -- When the client sends a certificate, check whether -- it is acceptable for the application. -- --- makeServerHello session = do srand <- getStateRNG ctx 32 >>= return . ServerRandom case mcred of Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey _ -> 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 0xff01 vf ] else return [] protoExt <- applicationProtocol let extensions = secRengExt ++ protoExt 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 SignatureRSA CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE SignatureDSS CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE SignatureRSA _ -> 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 confgure CA -- certificates. -- when (serverWantClientCert sparams) $ do usedVersion <- usingState_ ctx getVersion let certTypes = [ CertificateType_RSA_Sign ] hashSigs = if usedVersion < TLS12 then Nothing else Just (supportedHashSignatures $ ctxSupported ctx) creq = CertRequest certTypes hashSigs (map extractCAname $ serverCACertificates sparams) usingHState ctx $ setCertReqSent True sendPacket ctx (Handshake [creq]) -- Send HelloDone sendPacket ctx (Handshake [ServerHelloDone]) extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert setup_DHE = do let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams (priv, pub) <- generateDHE ctx dhparams let serverParams = serverDHParamsFrom dhparams pub usingHState ctx $ setServerDHParams serverParams usingHState ctx $ modify $ \hst -> hst { hstDHPrivate = Just priv } return (serverParams) generateSKX_DHE sigAlg = do serverParams <- setup_DHE signed <- digitallySignDHParams ctx serverParams sigAlg case sigAlg of SignatureRSA -> return $ SKX_DHE_RSA serverParams signed SignatureDSS -> return $ SKX_DHE_DSS serverParams signed _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg) generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE setup_ECDHE curvename = do let ecdhparams = ecdhParams curvename (priv, pub) <- generateECDHE ctx ecdhparams let serverParams = ServerECDHParams ecdhparams pub usingHState ctx $ setServerECDHParams serverParams usingHState ctx $ modify $ \hst -> hst { hstECDHPrivate = Just priv } return (serverParams) generateSKX_ECDHE sigAlg = do ncs <- usingState_ ctx $ getClientEllipticCurveSuggest let common = availableEllipticCurves `intersect` fromJust "ClientEllipticCurveSuggest" ncs -- FIXME: Currently maximum strength is chosen. -- There may be a better way to choose EC. nc = if null common then error "No common EllipticCurves" else maximum $ map fromEnumSafe16 common serverParams <- setup_ECDHE nc signed <- digitallySignECDHParams ctx serverParams sigAlg case sigAlg of SignatureRSA -> return $ SKX_ECDHE_RSA serverParams signed _ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg) -- 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 -- <- [NPN] -- <- finish -- recvClientData :: ServerParams -> Context -> IO () recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) where processClientCertificate (Certificates certs) = do -- run certificate recv hook ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs) -- Call application callback to see whether the -- certificate chain is acceptable. -- usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason -- Remember cert chain for later use. -- usingHState ctx $ setClientCertChain 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@(DigitallySigned mbHashSig _))]) = do processHandshake ctx hs checkValidClientCertChain "change cipher message expected" usedVersion <- usingState_ ctx getVersion -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages verif <- certificateVerifyCheck ctx usedVersion mbHashSig msgs dsig case verif of True -> do -- When verification succeeds, commit the -- client certificate chain to the context. -- Just certs <- usingHState ctx $ getClientCertChain usingState_ ctx $ setClientCertificateChain certs return () False -> do -- Either verification failed because of an -- invalid format (with an error message), or -- the signature is wrong. In either case, -- ask the application if it wants to -- proceed, we will do that. res <- 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. Just certs <- usingHState ctx $ getClientCertChain usingState_ ctx $ setClientCertificateChain certs else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) 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 npn <- usingState_ ctx getExtensionNPN return $ RecvStateHandshake $ if npn then expectNPN else expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectNPN (HsNextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegotiation") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") checkValidClientCertChain msg = do chain <- usingHState ctx $ getClientCertChain let throwerror = Error_Protocol (msg , True, UnexpectedMessage) case chain of Nothing -> throwCore throwerror Just cc | isNullCertificateChain cc -> throwCore throwerror | otherwise -> return () findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ reverse $ sortBy compare allowedVersions of [] -> Nothing v:_ -> Just v tls-1.3.8/Network/TLS/Handshake/Signature.hs0000644000000000000000000002145212715016070016774 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Signature -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Signature ( certificateVerifyCreate , certificateVerifyCheck , digitallySignDHParams , digitallySignECDHParams , digitallySignDHParamsVerify , digitallySignECDHParamsVerify ) where import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Packet (generateCertificateVerify_SSL, encodeSignedDHParams, encodeSignedECDHParams) import Network.TLS.Parameters (supportedHashSignatures) import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Key import Network.TLS.Util import Control.Monad.State certificateVerifyCheck :: Context -> Version -> Maybe HashAndSignatureAlgorithm -> Bytes -> DigitallySigned -> IO Bool certificateVerifyCheck ctx usedVersion malg msgs dsig = prepareCertificateVerifySignatureData ctx usedVersion malg msgs >>= signatureVerifyWithHashDescr ctx SignatureRSA dsig certificateVerifyCreate :: Context -> Version -> Maybe HashAndSignatureAlgorithm -> Bytes -> IO DigitallySigned certificateVerifyCreate ctx usedVersion malg msgs = prepareCertificateVerifySignatureData ctx usedVersion malg msgs >>= signatureCreate ctx malg getHashAndASN1 :: MonadIO m => (HashAlgorithm, SignatureAlgorithm) -> m Hash getHashAndASN1 hashSig = case hashSig of (HashSHA1, SignatureRSA) -> return SHA1 (HashSHA224, SignatureRSA) -> return SHA224 (HashSHA256, SignatureRSA) -> return SHA256 (HashSHA384, SignatureRSA) -> return SHA384 (HashSHA512, SignatureRSA) -> return SHA512 _ -> throwCore $ Error_Misc "unsupported hash/sig algorithm" type CertVerifyData = (Hash, Bytes) prepareCertificateVerifySignatureData :: Context -> Version -> Maybe HashAndSignatureAlgorithm -> Bytes -> IO CertVerifyData prepareCertificateVerifySignatureData ctx usedVersion malg msgs | usedVersion == SSL3 = do Just masterSecret <- usingHState ctx $ gets hstMasterSecret return (SHA1_MD5, generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit SHA1_MD5) msgs)) | usedVersion == TLS10 || usedVersion == TLS11 = do return (SHA1_MD5, hashFinal $ hashUpdate (hashInit SHA1_MD5) msgs) | otherwise = do let Just hashSig = malg hsh <- getHashAndASN1 hashSig return (hsh, msgs) signatureHashData :: SignatureAlgorithm -> Maybe HashAlgorithm -> Hash signatureHashData SignatureRSA mhash = case mhash of Just HashSHA512 -> SHA512 Just HashSHA384 -> SHA384 Just HashSHA256 -> SHA256 Just HashSHA1 -> SHA1 Nothing -> SHA1_MD5 Just hsh -> error ("unimplemented RSA signature hash type: " ++ show hsh) signatureHashData SignatureDSS mhash = case mhash of Nothing -> SHA1 Just HashSHA1 -> SHA1 Just _ -> error "invalid DSA hash choice, only SHA1 allowed" signatureHashData SignatureECDSA mhash = case mhash of Just HashSHA512 -> SHA512 Just HashSHA384 -> SHA384 Just HashSHA256 -> SHA256 Just HashSHA1 -> SHA1 Nothing -> SHA1_MD5 Just hsh -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) signatureHashData sig _ = error ("unimplemented signature type: " ++ show sig) --signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> HashDescr -> Bytes -> IO DigitallySigned signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned signatureCreate ctx malg (hashAlg, toSign) = do cc <- usingState_ ctx $ isClientContext let signData = case (malg, hashAlg) of (Nothing, SHA1_MD5) -> hashFinal $ hashUpdate (hashInit SHA1_MD5) toSign _ -> toSign DigitallySigned malg <$> signRSA ctx cc hashAlg signData signatureVerify :: Context -> DigitallySigned -> SignatureAlgorithm -> Bytes -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) sigAlgExpected toVerifyData = do usedVersion <- usingState_ ctx getVersion -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as -- the SHA_MD5 algorithm expect an already digested data let (hashDescr, toVerify) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" (TLS12, Just (h,s)) | s == sigAlgExpected -> (signatureHashData sigAlgExpected (Just h), toVerifyData) | otherwise -> error "expecting different signature algorithm" (_, Nothing) -> case signatureHashData sigAlgExpected Nothing of SHA1_MD5 -> (SHA1_MD5, hashFinal $ hashUpdate (hashInit SHA1_MD5) toVerifyData) alg -> (alg, toVerifyData) (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" signatureVerifyWithHashDescr ctx sigAlgExpected digSig (hashDescr, toVerify) signatureVerifyWithHashDescr :: Context -> SignatureAlgorithm -> DigitallySigned -> CertVerifyData -> IO Bool signatureVerifyWithHashDescr ctx sigAlgExpected (DigitallySigned _ bs) (hashDescr, toVerify) = do cc <- usingState_ ctx $ isClientContext case sigAlgExpected of SignatureRSA -> verifyRSA ctx cc hashDescr toVerify bs SignatureDSS -> verifyRSA ctx cc hashDescr toVerify bs SignatureECDSA -> verifyRSA ctx cc hashDescr toVerify bs _ -> error "signature verification not implemented yet" digitallySignParams :: Context -> Bytes -> SignatureAlgorithm -> IO DigitallySigned digitallySignParams ctx signatureData sigAlg = do usedVersion <- usingState_ ctx getVersion let mhash = case usedVersion of TLS12 -> case filter ((==) sigAlg . snd) $ supportedHashSignatures $ ctxSupported ctx of [] -> error ("no hash signature for " ++ show sigAlg) x:_ -> Just (fst x) _ -> Nothing let hashDescr = signatureHashData sigAlg mhash signatureCreate ctx (fmap (\h -> (h, sigAlg)) mhash) (hashDescr, signatureData) digitallySignDHParams :: Context -> ServerDHParams -> SignatureAlgorithm -> IO DigitallySigned digitallySignDHParams ctx serverParams sigAlg = do dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams digitallySignParams ctx dhParamsData sigAlg digitallySignECDHParams :: Context -> ServerECDHParams -> SignatureAlgorithm -> IO DigitallySigned digitallySignECDHParams ctx serverParams sigAlg = do ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams digitallySignParams ctx ecdhParamsData sigAlg digitallySignDHParamsVerify :: Context -> ServerDHParams -> SignatureAlgorithm -> DigitallySigned -> IO Bool digitallySignDHParamsVerify ctx dhparams sigAlg signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedDHParams dhparams signatureVerify ctx signature sigAlg expectedData digitallySignECDHParamsVerify :: Context -> ServerECDHParams -> SignatureAlgorithm -> DigitallySigned -> IO Bool digitallySignECDHParamsVerify ctx dhparams sigAlg signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedECDHParams dhparams signatureVerify ctx signature sigAlg 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 tls-1.3.8/Network/TLS/Handshake/State.hs0000644000000000000000000002652512715016070016121 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Handshake.State -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.State ( HandshakeState(..) , ClientCertRequestData , HandshakeM , newEmptyHandshake , runHandshake -- * key accessors , setPublicKey , setPrivateKey , getLocalPrivateKey , getRemotePublicKey , setServerDHParams , setServerECDHParams -- * cert accessors , setClientCertSent , getClientCertSent , setCertReqSent , getCertReqSent , setClientCertChain , getClientCertChain , setClientCertRequest , getClientCertRequest -- * digest accessors , addHandshakeMessage , updateHandshakeDigest , getHandshakeMessages , getHandshakeDigest -- * master secret , setMasterSecret , setMasterSecretFromPre -- * misc accessor , getPendingCipher , setServerHelloParameters ) 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 Control.Applicative (Applicative, (<$>)) import Control.Monad.State import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey) , hksLocalPrivateKey :: !(Maybe PrivKey) } deriving (Show) data HandshakeState = HandshakeState { hstClientVersion :: !(Version) , hstClientRandom :: !ClientRandom , hstServerRandom :: !(Maybe ServerRandom) , hstMasterSecret :: !(Maybe Bytes) , hstKeyState :: !HandshakeKeyState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams) , hstECDHPrivate :: !(Maybe ECDHPrivate) , hstHandshakeDigest :: !(Either [Bytes] HashCtx) , hstHandshakeMessages :: [Bytes] , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent , hstClientCertChain :: !(Maybe CertificateChain) , hstPendingTxState :: Maybe RecordState , hstPendingRxState :: Maybe RecordState , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression } deriving (Show) type ClientCertRequestData = ([CertificateType], Maybe [(HashAlgorithm, SignatureAlgorithm)], [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 , hstECDHPrivate = Nothing , hstHandshakeDigest = Left [] , hstHandshakeMessages = [] , hstClientCertRequest = Nothing , hstClientCertSent = False , hstCertReqSent = False , hstClientCertChain = Nothing , hstPendingTxState = Nothing , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression } 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 } setPrivateKey :: PrivKey -> HandshakeM () setPrivateKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) }) where setPK hks = hks { hksLocalPrivateKey = Just pk } getRemotePublicKey :: HandshakeM PubKey getRemotePublicKey = fromJust "remote public key" <$> gets (hksRemotePublicKey . hstKeyState) getLocalPrivateKey :: HandshakeM PrivKey getLocalPrivateKey = fromJust "local private key" <$> gets (hksLocalPrivateKey . hstKeyState) setServerDHParams :: ServerDHParams -> HandshakeM () setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) setServerECDHParams :: ServerECDHParams -> HandshakeM () setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp }) 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 setClientCertRequest :: ClientCertRequestData -> HandshakeM () setClientCertRequest d = modify (\hst -> hst { hstClientCertRequest = Just d }) getClientCertRequest :: HandshakeM (Maybe ClientCertRequestData) getClientCertRequest = gets hstClientCertRequest getPendingCipher :: HandshakeM Cipher getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher addHandshakeMessage :: Bytes -> HandshakeM () addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: HandshakeM [Bytes] getHandshakeMessages = gets (reverse . hstHandshakeMessages) updateHandshakeDigest :: Bytes -> HandshakeM () updateHandshakeDigest content = modify $ \hs -> hs { hstHandshakeDigest = case hstHandshakeDigest hs of Left bytes -> Left (content:bytes) Right hashCtx -> Right $ hashUpdate hashCtx content } getHandshakeDigest :: Version -> Role -> HandshakeM Bytes getHandshakeDigest ver role = gets gen where gen hst = case hstHandshakeDigest hst of Right hashCtx -> let msecret = fromJust "master secret" $ hstMasterSecret hst in generateFinish ver msecret hashCtx Left _ -> 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 () setMasterSecretFromPre ver role premasterSecret = do secret <- genSecret <$> get setMasterSecret ver role secret where genSecret hst = generateMasterSecret ver premasterSecret (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) -- | 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 -> Bytes -> 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 -> Bytes -> 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 (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 = if ver < TLS12 then SHA1_MD5 else SHA256 updateDigest (Left bytes) = Right $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes updateDigest (Right _) = error "cannot initialize digest with another digest" tls-1.3.8/Network/TLS/Record/0000755000000000000000000000000012715016070014023 5ustar0000000000000000tls-1.3.8/Network/TLS/Record/Disengage.hs0000644000000000000000000001441112715016070016246 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. -- {-# LANGUAGE FlexibleContexts #-} module Network.TLS.Record.Disengage ( disengageRecord ) where import Control.Monad.State 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 Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) 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 = onRecordFragment record $ fragmentUncipher $ \e -> do st <- get case stCipher st of Nothing -> return e _ -> getRecordVersion >>= \ver -> decryptData ver record e st 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 paddingValid <- case cipherDataPadding cdata of Nothing -> return True Just pad -> do cver <- getRecordVersion let b = B.length pad - 1 return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) unless (macValid &&! paddingValid) $ do throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) return $ cipherDataContent cdata decryptData :: Version -> Record Ciphertext -> Bytes -> RecordState -> RecordM Bytes 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 Bytes 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 get2 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) <- get3 content' (contentlen, macSize, paddinglength) getCipherData record $ CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Just padding } 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) <- get2 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) <- get3 econtent (nonceExpLen, cipherLen, authTagLen) let encodedSeq = encodeWord64 $ msSequence $ stMacState tst Header typ v _ = recordToHeader record hdr = Header typ v $ fromIntegral cipherLen ad = B.concat [ encodedSeq, encodeHeader hdr ] nonce = cstIV (stCryptState tst) `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) get3 s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls get2 s (d1,d2) = get3 s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) tls-1.3.8/Network/TLS/Record/Engage.hs0000644000000000000000000000764312715016070015557 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. -- {-# LANGUAGE BangPatterns #-} module Network.TLS.Record.Engage ( engageRecord ) where import Control.Applicative import Control.Monad.State 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 Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) 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 = onRecordFragment record $ fragmentCipher $ \bytes -> do st <- get case stCipher st of Nothing -> return bytes _ -> encryptContent record bytes encryptContent :: Record Compressed -> ByteString -> RecordM ByteString encryptContent 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 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 :: BulkAEAD -> ByteString -> Record Compressed -> RecordM ByteString encryptAead encryptF content record = do cst <- getCryptState encodedSeq <- encodeWord64 <$> getMacSequence let hdr = recordToHeader record ad = B.concat [encodedSeq, encodeHeader hdr] nonce = B.concat [cstIV cst, encodedSeq] (e, AuthTag authtag) = encryptF nonce content ad modify incrRecordState return $ B.concat [encodedSeq, e, B.convert authtag] getCryptState :: RecordM CryptState getCryptState = stCryptState <$> get tls-1.3.8/Network/TLS/Record/State.hs0000644000000000000000000001044512715016070015443 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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(..) , RecordState(..) , newRecordState , incrRecordState , RecordM , runRecordM , getRecordVersion , setRecordIV , withCompression , computeDigest , makeDigest , getBulk , getMacSequence ) where import Data.Word import Control.Applicative import Control.Monad.State 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 qualified Data.ByteString as B data CryptState = CryptState { cstKey :: !BulkState , cstIV :: !Bytes , cstMacSecret :: !Bytes } deriving (Show) newtype MacState = MacState { msSequence :: Word64 } deriving (Show) data RecordState = RecordState { stCipher :: Maybe Cipher , stCompression :: Compression , stCryptState :: !CryptState , stMacState :: !MacState } deriving (Show) newtype RecordM a = RecordM { runRecordM :: Version -> 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 $ \ver st -> do case runRecordM m1 ver st of Left err -> Left err Right (a, st2) -> runRecordM (m2 a) ver st2 instance Functor RecordM where fmap f m = RecordM $ \ver st -> case runRecordM m ver st of Left err -> Left err Right (a, st2) -> Right (f a, st2) getRecordVersion :: RecordM Version getRecordVersion = RecordM $ \ver st -> Right (ver, st) 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 $ \ver st -> case runRecordM m ver st of Left err -> runRecordM (f err) ver 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 :: Bytes -> 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 -> Bytes -> (Bytes, 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 -> Bytes -> RecordM Bytes 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.3.8/Network/TLS/Record/Types.hs0000644000000000000000000000643012715016070015466 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 , fragmentCiphertext , Plaintext , Compressed , Ciphertext -- * manipulate record , onRecordFragment , fragmentCompress , fragmentCipher , fragmentUncipher , fragmentUncompress -- * serialize record , rawToRecord , recordToRaw , recordToHeader ) where import Network.TLS.Struct import Network.TLS.Record.State import qualified Data.ByteString as B import Control.Applicative ((<$>)) -- | Represent a TLS record. data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) newtype Fragment a = Fragment { fragmentGetBytes :: Bytes } deriving (Show,Eq) data Plaintext data Compressed data Ciphertext fragmentPlaintext :: Bytes -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes fragmentCiphertext :: Bytes -> 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 :: (Bytes -> RecordM Bytes) -> 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 :: (Bytes -> RecordM Bytes) -> Fragment Plaintext -> RecordM (Fragment Compressed) fragmentCompress f = fragmentMap f -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (Bytes -> RecordM Bytes) -> Fragment Compressed -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied fragmentUncipher :: (Bytes -> RecordM Bytes) -> Fragment Ciphertext -> RecordM (Fragment Compressed) fragmentUncipher f = fragmentMap f -- | turn a compressed fragment into a plaintext fragment using the decompression function supplied fragmentUncompress :: (Bytes -> RecordM Bytes) -> Fragment Compressed -> RecordM (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, Bytes) 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.3.8/Network/TLS/Util/0000755000000000000000000000000012715016070013522 5ustar0000000000000000tls-1.3.8/Network/TLS/Util/ASN1.hs0000644000000000000000000000231412715016070014560 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 Data.ASN1.Types (fromASN1, toASN1, ASN1Object) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..)) import Data.ByteString (ByteString) -- | 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.3.8/Network/TLS/Util/Serialization.hs0000644000000000000000000000040512715016070016672 0ustar0000000000000000module Network.TLS.Util.Serialization ( os2ip , i2osp , i2ospOf_ , lengthBytes ) where import Crypto.Number.Basic (numBytes) import Crypto.Number.Serialize (os2ip, i2osp, i2ospOf_) lengthBytes :: Integer -> Int lengthBytes = numBytes tls-1.3.8/Tests/0000755000000000000000000000000012715016070011614 5ustar0000000000000000tls-1.3.8/Tests/Certificate.hs0000644000000000000000000000616712715016070014404 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Certificate ( arbitraryX509 , arbitraryX509WithKey , simpleCertificate , simpleX509 ) where import Control.Applicative import Test.Tasty.QuickCheck import Data.X509 import Data.Hourglass import qualified Data.ByteString as B import PubKey testExtensionEncode critical ext = ExtensionRaw (extOID ext) critical (extEncode ext) 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 = 16777216 arbitraryCertificate pubKey = do serial <- choose (0,maxSerial) issuerdn <- arbitraryDN subjectdn <- arbitraryDN validity <- (,) <$> arbitrary <*> arbitrary let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) return $ Certificate { certVersion = 3 , certSerial = serial , certSignatureAlg = sigalg , certIssuerDN = issuerdn , certSubjectDN = subjectdn , certValidity = validity , certPubKey = pubKey , certExtensions = Extensions $ Just [ testExtensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment,KeyUsage_keyCertSign] ] } simpleCertificate pubKey = Certificate { certVersion = 3 , certSerial = 0 , certSignatureAlg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) , certIssuerDN = simpleDN , certSubjectDN = simpleDN , certValidity = (time1, time2) , certPubKey = pubKey , certExtensions = Extensions $ Just [ testExtensionEncode 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 = do let cert = simpleCertificate pubKey sig = replicate 40 1 sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert in signedExact arbitraryX509WithKey (pubKey, _) = do cert <- arbitraryCertificate pubKey sig <- resize 40 $ listOf1 arbitrary let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert return signedExact arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) tls-1.3.8/Tests/Ciphers.hs0000644000000000000000000000341512715016070013550 0ustar0000000000000000module 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 (fromIntegral $ bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (fromIntegral $ bulkIVSize bulk) arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (fromIntegral $ 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.3.8/Tests/Connection.hs0000644000000000000000000001351512715016070014254 0ustar0000000000000000module Connection ( newPairContext , arbitraryPairParams , setPairParamsSessionManager , setPairParamsSessionResuming , establishDataPipe , blockCipher , streamCipher ) where import Test.Tasty.QuickCheck import Certificate import PubKey import PipeChan import Network.TLS import Data.X509 import Data.Default.Class import Control.Applicative import Control.Concurrent.Chan import Control.Concurrent import qualified Control.Exception as E import qualified Data.ByteString as B debug = False 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 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } blockCipherDHE_RSA :: Cipher blockCipherDHE_RSA = blockCipher { cipherID = 0xff14 , cipherName = "dhe-rsa-id-const" , cipherKeyExchange = CipherKeyExchange_DHE_RSA } blockCipherDHE_DSS :: Cipher blockCipherDHE_DSS = blockCipher { cipherID = 0xff15 , cipherName = "dhe-dss-id-const" , cipherKeyExchange = CipherKeyExchange_DHE_DSS } streamCipher :: Cipher streamCipher = blockCipher { cipherID = 0xff13 , cipherBulk = Bulk { bulkName = "stream" , bulkKeySize = 16 , bulkIVSize = 0 , bulkExplicitIV= 0 , bulkAuthTagLen= 0 , bulkBlockSize = 0 , bulkF = BulkStreamF passThrough } } where passThrough _ _ = BulkStream go where go inp = (inp, BulkStream go) knownCiphers :: [Cipher] knownCiphers = [blockCipher,blockCipherDHE_RSA,blockCipherDHE_DSS,streamCipher] knownVersions :: [Version] knownVersions = [SSL3,TLS10,TLS11,TLS12] arbitraryPairParams = do (dsaPub, dsaPriv) <- (\(p,r) -> (PubKeyDSA p, PrivKeyDSA r)) <$> arbitraryDSAPair let (pubKey, privKey) = (\(p, r) -> (PubKeyRSA p, PrivKeyRSA r)) $ getGlobalRSAPair creds <- mapM (\(pub, priv) -> do cert <- arbitraryX509WithKey (pub, priv) return (CertificateChain [cert], priv) ) [ (pubKey, privKey), (dsaPub, dsaPriv) ] connectVersion <- elements knownVersions let allowedVersions = [ v | v <- knownVersions, v <= connectVersion ] serAllowedVersions <- (:[]) `fmap` elements allowedVersions serverCiphers <- arbitraryCiphers clientCiphers <- oneof [arbitraryCiphers] `suchThat` (\cs -> or [x `elem` serverCiphers | x <- cs]) secNeg <- arbitrary let serverState = def { serverSupported = def { supportedCiphers = serverCiphers , supportedVersions = serAllowedVersions , supportedSecureRenegotiation = secNeg } , serverDHEParams = Just dhParams , serverShared = def { sharedCredentials = Credentials creds } } let clientState = (defaultParamsClient "" B.empty) { clientSupported = def { supportedCiphers = clientCiphers , supportedVersions = allowedVersions , supportedSecureRenegotiation = secNeg } , clientShared = def { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () , cacheQuery = \_ _ _ -> return ValidationCachePass } } } return (clientState, serverState) where arbitraryCiphers = resize (length knownCiphers + 1) $ listOf1 (elements knownCiphers) setPairParamsSessionManager :: SessionManager -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionManager manager (clientState, serverState) = (nc,ns) where nc = clientState { clientShared = updateSessionManager $ clientShared clientState } ns = serverState { serverShared = updateSessionManager $ serverShared serverState } updateSessionManager shared = shared { sharedSessionManager = manager } setPairParamsSessionResuming sessionStuff (clientState, serverState) = ( clientState { clientWantSessionResume = Just sessionStuff } , serverState) 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 establishDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe _ <- (runPipe pipe) startQueue <- newChan resultQueue <- newChan (cCtx, sCtx) <- newPairContext pipe params _ <- forkIO $ E.catch (tlsServer sCtx resultQueue) (printAndRaise "server") _ <- forkIO $ E.catch (tlsClient startQueue cCtx) (printAndRaise "client") return (startQueue, resultQueue) where printAndRaise :: String -> E.SomeException -> IO () printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> E.throw e tls-1.3.8/Tests/Marshalling.hs0000644000000000000000000000677112715016070014424 0ustar0000000000000000{-# LANGUAGE CPP #-} module Marshalling 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 import Certificate genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i instance Arbitrary Version where arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ] 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 -> liftM (Session . Just) (genByteString 32) _ -> return $ Session Nothing 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 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int)) 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 [ ClientHello <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryCiphersIDs <*> arbitraryCompressionIDs <*> (return []) <*> (return Nothing) , ServerHello <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> (return []) , liftM Certificates (CertificateChain <$> (resize 2 $ listOf $ arbitraryX509)) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg . CKX_RSA <$> genByteString 48 --, liftM ServerKeyXchg , liftM3 CertRequest arbitrary (return Nothing) (return []) , CertVerify <$> arbitrary , Finished <$> (genByteString 12) ] {- 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 = case decodeHandshakeRecord b of GotPartial _ -> error "got partial" GotError e -> error ("got error: " ++ show e) GotSuccessRemaining _ _ -> error "got remaining byte left" GotSuccess (ty, content) -> decodeHandshake cp ty content cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA, cParamsSupportNPN = True } tls-1.3.8/Tests/PipeChan.hs0000644000000000000000000000343012715016070013637 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 = UniPipeChan <$> newChan <*> newChan runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w getReadUniPipe (UniPipeChan r _) = r getWriteUniPipe (UniPipeChan _ w) = w -- | Represent a bidirectional pipe with 2 nodes A and B data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s -- helper to read buffered data. 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.3.8/Tests/PubKey.hs0000644000000000000000000000654212715016070013356 0ustar0000000000000000module PubKey ( arbitraryRSAPair , arbitraryDSAPair , globalRSAPair , getGlobalRSAPair , dhParams , dsaParams , rsaParams ) where import Test.Tasty.QuickCheck import qualified Crypto.PubKey.DH as DH import Crypto.Random import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA 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 dhParams :: DH.Params dhParams = DH.Params { DH.params_p = 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb , DH.params_g = 0x2 , DH.params_bits = 512 } 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) tls-1.3.8/Tests/Tests.hs0000644000000000000000000001445312715016070013261 0ustar0000000000000000{-# LANGUAGE CPP #-} import Test.Tasty import Test.Tasty.QuickCheck import Test.QuickCheck.Monadic import PipeChan import Connection import Marshalling import Ciphers import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Network.TLS import Control.Applicative import Control.Concurrent import Control.Monad import Data.IORef 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 () recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l runTLSPipe params tlsServer tlsClient = do (startQueue, resultQueue) <- run (establishDataPipe params tlsServer tlsClient) -- send some data d <- B.pack <$> pick (someWords8 256) run $ writeChan startQueue d -- receive it dres <- run $ timeout 10000000 $ readChan resultQueue -- check if it equal Just d `assertEq` dres return () prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do params <- pick arbitraryPairParams runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () prop_handshake_npn_initiate :: PropertyM IO () prop_handshake_npn_initiate = do (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onNPNServerSuggest = Just $ \protos -> return (head protos) } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onSuggestNextProtocols = return $ Just [C8.pack "spdy/2", C8.pack "http/1.1"] } } params' = (clientParam',serverParam') runTLSPipe params' tlsServer tlsClient where tlsServer ctx queue = do handshake ctx proto <- getNegotiatedProtocol ctx Just (C8.pack "spdy/2") `assertEq` proto d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx proto <- getNegotiatedProtocol ctx Just (C8.pack "spdy/2") `assertEq` proto d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () prop_handshake_renegociation :: PropertyM IO () prop_handshake_renegociation = do (cparams, sparams) <- pick arbitraryPairParams let sparams' = sparams { serverSupported = (serverSupported sparams) { supportedClientInitiatedRenegotiation = True } } runTLSPipe (cparams, sparams') tlsServer tlsClient where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () -- | 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 -> (>>= maybeResume myId) <$> readIORef ref , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) , sessionInvalidate = \_ -> return () } where maybeResume myId (sid, sdata) | sid == myId = Just sdata | otherwise = Nothing prop_handshake_session_resumption :: PropertyM IO () prop_handshake_session_resumption = do sessionRef <- run $ newIORef Nothing let sessionManager = oneSessionManager sessionRef plainParams <- pick arbitraryPairParams let params = setPairParamsSessionManager sessionManager plainParams runTLSPipe params tlsServer tlsClient -- and resume sessionParams <- run $ readIORef sessionRef assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPipe params2 tlsServer tlsClient where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () 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) main :: IO () main = defaultMain $ testGroup "tls" [ tests_marshalling , tests_ciphers , tests_handshake ] where -- lowlevel tests to check the packet marshalling. tests_marshalling = testGroup "Marshalling" [ testProperty "Header" prop_header_marshalling_id , testProperty "Handshake" prop_handshake_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 "initiate" (monadicIO prop_handshake_initiate) , testProperty "npnInitiate" (monadicIO prop_handshake_npn_initiate) , testProperty "renegociation" (monadicIO prop_handshake_renegociation) , testProperty "resumption" (monadicIO prop_handshake_session_resumption) ]