tls-1.4.1/Benchmarks/0000755000000000000000000000000013137673636012601 5ustar0000000000000000tls-1.4.1/Network/0000755000000000000000000000000013215475646012153 5ustar0000000000000000tls-1.4.1/Network/TLS/0000755000000000000000000000000013246063515012605 5ustar0000000000000000tls-1.4.1/Network/TLS/Context/0000755000000000000000000000000013240574164014232 5ustar0000000000000000tls-1.4.1/Network/TLS/Crypto/0000755000000000000000000000000013215475646014075 5ustar0000000000000000tls-1.4.1/Network/TLS/Extra/0000755000000000000000000000000013240574164013671 5ustar0000000000000000tls-1.4.1/Network/TLS/Handshake/0000755000000000000000000000000013240574732014475 5ustar0000000000000000tls-1.4.1/Network/TLS/Record/0000755000000000000000000000000013240574164014024 5ustar0000000000000000tls-1.4.1/Network/TLS/Util/0000755000000000000000000000000013215475646013532 5ustar0000000000000000tls-1.4.1/Tests/0000755000000000000000000000000013241103064011601 5ustar0000000000000000tls-1.4.1/Network/TLS.hs0000644000000000000000000000716513215475646013162 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS ( -- * Context configuration ClientParams(..) , HostName , Bytes , ServerParams(..) , DebugParams(..) , DHParams , DHPublic , ClientHooks(..) , ServerHooks(..) , Supported(..) , Shared(..) , Hooks(..) , Handshake , Logging(..) , Measurement(..) , GroupUsage(..) , 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(..) , ClientRandom , ServerRandom , unClientRandom , unServerRandom , contextGetInformation -- * Credentials , Credentials(..) , Credential , credentialLoadX509 , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory -- * Initialisation and Termination of context , bye , handshake -- * Application Layer 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 -- * Key exchange group , Group(..) ) where import Network.TLS.Backend (Backend(..), HasBackend(..)) import Network.TLS.Struct ( TLSError(..), TLSException(..) , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..) , Header(..), ProtocolType(..), CertificateType(..) , AlertDescription(..) , ClientRandom(..), ServerRandom(..) , Handshake) import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) 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 import Data.ByteString as B {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-} type Bytes = B.ByteString tls-1.4.1/Network/TLS/Cipher.hs0000644000000000000000000001166213240574164014362 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, 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 , cipherPRFHash :: Maybe Hash } cipherKeyBlockSize :: Cipher -> Int cipherKeyBlockSize cipher = 2 * (hashDigestSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk) where bulk = cipherBulk cipher -- | Check if a specific 'Cipher' is allowed to be used -- with the version specified cipherAllowedForVersion :: Version -> Cipher -> Bool cipherAllowedForVersion ver cipher = case cipherMinVer cipher of Nothing -> 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.4.1/Network/TLS/Compression.hs0000644000000000000000000000514613240574164015451 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Network.TLS.Compression -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Compression ( CompressionC(..) , Compression(..) , CompressionID , nullCompression , NullCompression -- * member redefined for the class abstraction , compressionID , compressionDeflate , compressionInflate -- * helper , compressionIntersectID ) where import Network.TLS.Types (CompressionID) import Network.TLS.Imports import Control.Arrow (first) -- | supported compression algorithms need to be part of this class class CompressionC a where compressionCID :: a -> CompressionID compressionCDeflate :: a -> ByteString -> (a, ByteString) compressionCInflate :: a -> ByteString -> (a, ByteString) -- | every compression need to be wrapped in this, to fit in structure data Compression = forall a . CompressionC a => Compression a -- | return the associated ID for this algorithm compressionID :: Compression -> CompressionID compressionID (Compression c) = compressionCID c -- | deflate (compress) a bytestring using a compression context and return the result -- along with the new compression context. compressionDeflate :: ByteString -> Compression -> (Compression, ByteString) compressionDeflate bytes (Compression c) = first Compression $ compressionCDeflate c bytes -- | inflate (decompress) a bytestring using a compression context and return the result -- along the new compression context. compressionInflate :: ByteString -> Compression -> (Compression, ByteString) compressionInflate bytes (Compression c) = first Compression $ compressionCInflate c bytes instance Show Compression where show = show . compressionID instance Eq Compression where (==) c1 c2 = compressionID c1 == compressionID c2 -- | intersect a list of ids commonly given by the other side with a list of compression -- the function keeps the list of compression in order, to be able to find quickly the prefered -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l -- | This is the default compression which is a NOOP. data NullCompression = NullCompression instance CompressionC NullCompression where compressionCID _ = 0 compressionCDeflate s b = (s, b) compressionCInflate s b = (s, b) -- | default null compression nullCompression :: Compression nullCompression = Compression NullCompression tls-1.4.1/Network/TLS/Internal.hs0000644000000000000000000000116413100036227014704 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.4.1/Network/TLS/Extra.hs0000644000000000000000000000060013100036227014205 0ustar0000000000000000-- | -- Module : Network.TLS.Extra -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- default values and ciphers module Network.TLS.Extra ( module Network.TLS.Extra.Cipher , module Network.TLS.Extra.FFDHE ) where import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE tls-1.4.1/Network/TLS/Extra/Cipher.hs0000644000000000000000000005664413240574164015456 0ustar0000000000000000-- | -- Module : Network.TLS.Extra.Cipher -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE CPP #-} module Network.TLS.Extra.Cipher ( -- * cipher suite ciphersuite_default , ciphersuite_all , ciphersuite_medium , ciphersuite_strong , ciphersuite_unencrypted , ciphersuite_dhe_rsa , ciphersuite_dhe_dss -- * individual ciphers , cipher_null_SHA1 , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_AES128_SHA256 , cipher_AES256_SHA256 , cipher_AES128GCM_SHA256 , cipher_AES256GCM_SHA384 , cipher_DHE_RSA_AES128_SHA1 , cipher_DHE_RSA_AES256_SHA1 , cipher_DHE_RSA_AES128_SHA256 , cipher_DHE_RSA_AES256_SHA256 , cipher_DHE_DSS_AES128_SHA1 , cipher_DHE_DSS_AES256_SHA1 , cipher_DHE_RSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256GCM_SHA384 , 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_AES128CBC_SHA , cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_ECDSA_AES128CBC_SHA256 , cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_ECDHE_ECDSA_AES256GCM_SHA384 -- * obsolete and non-standard ciphers , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 , cipher_null_MD5 , cipher_DHE_DSS_RC4_SHA1 ) where import qualified Data.ByteString as B import Network.TLS.Types (Version(..)) import Network.TLS.Cipher import Network.TLS.Imports import Data.Tuple (swap) import Crypto.Cipher.AES import qualified Crypto.Cipher.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_ = fromMaybe (error "makeIV_") . makeIV tripledes_ede :: BulkDirection -> BulkKey -> BulkBlock tripledes_ede BulkEncrypt key = let ctx = noFail $ cipherInit key in (\iv input -> let output = cbcEncrypt ctx (tripledes_iv iv) input in (output, takelast 8 output)) tripledes_ede BulkDecrypt key = let ctx = noFail $ cipherInit key in (\iv input -> let output = cbcDecrypt ctx (tripledes_iv iv) input in (output, takelast 8 input)) tripledes_iv :: BulkIV -> IV DES_EDE3 tripledes_iv iv = fromMaybe (error "tripledes cipher iv internal error") $ makeIV iv rc4 :: BulkDirection -> BulkKey -> BulkStream rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey) where combineRC4 ctx input = let (ctx', output) = RC4.combine ctx input in (output, BulkStream (combineRC4 ctx')) -- | All AES ciphers supported ordered from strong to weak. This choice -- of ciphersuites should satisfy most normal needs. For otherwise strong -- ciphers we make little distinction between AES128 and AES256, and list -- each but the weakest of the AES128 ciphers ahead of the corresponding AES256 -- ciphers. ciphersuite_default :: [Cipher] ciphersuite_default = [ -- First the PFS + GCM + SHA2 ciphers cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384 -- Next the PFS + CBC + SHA2 ciphers , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384 , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256 -- Next the PFS + CBC + SHA1 ciphers , cipher_ECDHE_ECDSA_AES128CBC_SHA, cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_RSA_AES128CBC_SHA, cipher_ECDHE_RSA_AES256CBC_SHA , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1 -- Next the non-PFS + GCM + SHA2 ciphers , cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384 -- Next the non-PFS + CBC + SHA2 ciphers , cipher_AES256_SHA256, cipher_AES128_SHA256 -- Next the non-PFS + CBC + SHA1 ciphers , cipher_AES256_SHA1, cipher_AES128_SHA1 -- Nobody uses or should use DSS, RC4, 3DES or MD5 -- , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 -- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 -- , cipher_RSA_3DES_EDE_CBC_SHA1 ] {-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} -- | The default ciphersuites + some not recommended last resort ciphers. ciphersuite_all :: [Cipher] ciphersuite_all = ciphersuite_default ++ [ cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_RC4_128_SHA1 ] {-# DEPRECATED ciphersuite_medium "Use ciphersuite_strong or ciphersuite_default instead." #-} -- | list of medium ciphers. ciphersuite_medium :: [Cipher] ciphersuite_medium = [ cipher_RC4_128_SHA1 , cipher_AES128_SHA1 ] -- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we -- list each AES128 variant right after the corresponding AES256 variant. For -- weaker constructs, we use just the AES256 form. ciphersuite_strong :: [Cipher] ciphersuite_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256 cipher_ECDHE_ECDSA_AES256GCM_SHA384, cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_ECDHE_RSA_AES256GCM_SHA384, cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES128GCM_SHA256 -- No AEAD , cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_AES256CBC_SHA384 , cipher_DHE_RSA_AES256_SHA256 -- No SHA2 , cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_RSA_AES256CBC_SHA , cipher_DHE_RSA_AES256_SHA1 -- No PFS , cipher_AES256GCM_SHA384 -- Neither PFS nor AEAD, just SHA2 , cipher_AES256_SHA256 -- Last resort no PFS, AEAD or SHA2 , cipher_AES256_SHA1 ] -- | DHE-RSA cipher suite ciphersuite_dhe_rsa :: [Cipher] ciphersuite_dhe_rsa = [ cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES128GCM_SHA256 , cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1 ] ciphersuite_dhe_dss :: [Cipher] ciphersuite_dhe_dss = [cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1, cipher_DHE_DSS_RC4_SHA1] -- | all unencrypted ciphers, do not use on insecure network. ciphersuite_unencrypted :: [Cipher] ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] bulk_null, bulk_rc4, bulk_aes128, bulk_aes256, bulk_tripledes_ede, bulk_aes128gcm, bulk_aes256gcm :: Bulk bulk_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 = 0x0001 , cipherName = "RSA-null-MD5" , cipherBulk = bulk_null , cipherHash = MD5 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | unencrypted cipher using RSA for key exchange and SHA1 for digest cipher_null_SHA1 :: Cipher cipher_null_SHA1 = Cipher { cipherID = 0x0002 , cipherName = "RSA-null-SHA1" , cipherBulk = bulk_null , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | RC4 cipher, RSA key exchange and MD5 for digest cipher_RC4_128_MD5 :: Cipher cipher_RC4_128_MD5 = Cipher { cipherID = 0x0004 , cipherName = "RSA-rc4-128-md5" , cipherBulk = bulk_rc4 , cipherHash = MD5 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | RC4 cipher, RSA key exchange and SHA1 for digest cipher_RC4_128_SHA1 :: Cipher cipher_RC4_128_SHA1 = Cipher { cipherID = 0x0005 , cipherName = "RSA-rc4-128-sha1" , cipherBulk = bulk_rc4 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | 3DES cipher (168 bit key), RSA key exchange and SHA1 for digest cipher_RSA_3DES_EDE_CBC_SHA1 :: Cipher cipher_RSA_3DES_EDE_CBC_SHA1 = Cipher { cipherID = 0x000A , cipherName = "RSA-3DES-EDE-CBC-SHA1" , cipherBulk = bulk_tripledes_ede , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } -- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest cipher_AES128_SHA1 :: Cipher cipher_AES128_SHA1 = Cipher { cipherID = 0x002F , cipherName = "RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just SSL3 } -- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest cipher_DHE_DSS_AES128_SHA1 :: Cipher cipher_DHE_DSS_AES128_SHA1 = Cipher { cipherID = 0x0032 , cipherName = "DHE-DSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_DHE_DSS , cipherMinVer = Nothing } -- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES128_SHA1 :: Cipher cipher_DHE_RSA_AES128_SHA1 = Cipher { cipherID = 0x0033 , cipherName = "DHE-RSA-AES128-SHA1" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Nothing } -- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest cipher_AES256_SHA1 :: Cipher cipher_AES256_SHA1 = Cipher { cipherID = 0x0035 , cipherName = "RSA-AES256-SHA1" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just SSL3 } -- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest cipher_DHE_DSS_AES256_SHA1 :: Cipher cipher_DHE_DSS_AES256_SHA1 = cipher_DHE_DSS_AES128_SHA1 { cipherID = 0x0038 , cipherName = "DHE-DSA-AES256-SHA1" , cipherBulk = bulk_aes256 } -- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES256_SHA1 :: Cipher cipher_DHE_RSA_AES256_SHA1 = cipher_DHE_RSA_AES128_SHA1 { cipherID = 0x0039 , cipherName = "DHE-RSA-AES256-SHA1" , cipherBulk = bulk_aes256 } -- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest cipher_AES128_SHA256 :: Cipher cipher_AES128_SHA256 = Cipher { cipherID = 0x003C , cipherName = "RSA-AES128-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } -- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest cipher_AES256_SHA256 :: Cipher cipher_AES256_SHA256 = Cipher { cipherID = 0x003D , cipherName = "RSA-AES256-SHA256" , cipherBulk = bulk_aes256 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } -- This is not registered in IANA. -- So, this will be removed in the next major release. cipher_DHE_DSS_RC4_SHA1 :: Cipher cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 { cipherID = 0x0066 , cipherName = "DHE-DSA-RC4-SHA1" , cipherBulk = bulk_rc4 } cipher_DHE_RSA_AES128_SHA256 :: Cipher cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1 { cipherID = 0x0067 , cipherName = "DHE-RSA-AES128-SHA256" , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherMinVer = Just TLS12 } cipher_DHE_RSA_AES256_SHA256 :: Cipher cipher_DHE_RSA_AES256_SHA256 = cipher_DHE_RSA_AES128_SHA256 { cipherID = 0x006B , cipherName = "DHE-RSA-AES256-SHA256" , cipherBulk = bulk_aes256 } -- | AESGCM cipher (128 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES128GCM_SHA256 :: Cipher cipher_AES128GCM_SHA256 = Cipher { cipherID = 0x009C , cipherName = "RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } -- | AESGCM cipher (256 bit key), RSA key exchange. -- The SHA384 digest is used as a PRF, not as a MAC. cipher_AES256GCM_SHA384 :: Cipher cipher_AES256GCM_SHA384 = Cipher { cipherID = 0x009D , cipherName = "RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Just TLS12 } cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher cipher_DHE_RSA_AES128GCM_SHA256 = Cipher { cipherID = 0x009E , cipherName = "DHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher cipher_DHE_RSA_AES256GCM_SHA384 = Cipher { cipherID = 0x009F , cipherName = "DHE-RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 } cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher { cipherID = 0xC009 , cipherName = "ECDHE-ECDSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS10 } cipher_ECDHE_ECDSA_AES256CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES256CBC_SHA = Cipher { cipherID = 0xC00A , cipherName = "ECDHE-ECDSA-AES256CBC-SHA" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS10 } cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA = Cipher { cipherID = 0xC013 , cipherName = "ECDHE-RSA-AES128CBC-SHA" , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS10 } cipher_ECDHE_RSA_AES256CBC_SHA :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA = Cipher { cipherID = 0xC014 , cipherName = "ECDHE-RSA-AES256CBC-SHA" , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS10 } cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher cipher_ECDHE_RSA_AES128CBC_SHA256 = Cipher { cipherID = 0xC027 , cipherName = "ECDHE-RSA-AES128CBC-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_RSA_AES256CBC_SHA384 = Cipher { cipherID = 0xC028 , cipherName = "ECDHE-RSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA256 = Cipher { cipherID = 0xc023 , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256" , cipherBulk = bulk_aes128 , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher cipher_ECDHE_ECDSA_AES256CBC_SHA384 = Cipher { cipherID = 0xC024 , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384" , cipherBulk = bulk_aes256 , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher { cipherID = 0xC02B , cipherName = "ECDHE-ECDSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher cipher_ECDHE_ECDSA_AES256GCM_SHA384 = Cipher { cipherID = 0xC02C , cipherName = "ECDHE-ECDSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289 } cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_RSA_AES128GCM_SHA256 = Cipher { cipherID = 0xC02F , cipherName = "ECDHE-RSA-AES128GCM-SHA256" , cipherBulk = bulk_aes128gcm , cipherHash = SHA256 , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher cipher_ECDHE_RSA_AES256GCM_SHA384 = Cipher { cipherID = 0xC030 , cipherName = "ECDHE-RSA-AES256GCM-SHA384" , cipherBulk = bulk_aes256gcm , cipherHash = SHA384 , cipherPRFHash = Just SHA384 , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA , cipherMinVer = Just TLS12 -- RFC 5289 } -- A list of cipher suite is found from: -- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 tls-1.4.1/Network/TLS/Extra/FFDHE.hs0000644000000000000000000001654613100036227015041 0ustar0000000000000000-- | -- Module : Network.TLS.Extra -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown -- -- Finite Field Diffie-Hellman Ephemeral Parameters defined in RFC 7919. module Network.TLS.Extra.FFDHE where import Crypto.PubKey.DH import Network.TLS.Crypto.DH (DHParams) -- | 2048 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 103 bits. ffdhe2048 :: DHParams ffdhe2048 = Params { params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B423861285C97FFFFFFFFFFFFFFFF , params_g = 2 , params_bits = 2048 } -- | 3072 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 125 bits. ffdhe3072 :: DHParams ffdhe3072 = Params { params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B66C62E37FFFFFFFFFFFFFFFF , params_g = 2 , params_bits = 3072 } -- | 4096 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 150 bits. ffdhe4096 :: DHParams ffdhe4096 = Params { params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E655F6AFFFFFFFFFFFFFFFF , params_g = 2 , params_bits = 4096 } -- | 6144 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 175 bits. ffdhe6144 :: DHParams ffdhe6144 = Params { params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CD0E40E65FFFFFFFFFFFFFFFF , params_g = 2 , params_bits = 6144 } -- | 8192 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 192 bits. ffdhe8192 :: DHParams ffdhe8192 = Params { params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CCFF46AAA36AD004CF600C8381E425A31D951AE64FDB23FCEC9509D43687FEB69EDD1CC5E0B8CC3BDF64B10EF86B63142A3AB8829555B2F747C932665CB2C0F1CC01BD70229388839D2AF05E454504AC78B7582822846C0BA35C35F5C59160CC046FD8251541FC68C9C86B022BB7099876A460E7451A8A93109703FEE1C217E6C3826E52C51AA691E0E423CFC99E9E31650C1217B624816CDAD9A95F9D5B8019488D9C0A0A1FE3075A577E23183F81D4A3F2FA4571EFC8CE0BA8A4FE8B6855DFE72B0A66EDED2FBABFBE58A30FAFABE1C5D71A87E2F741EF8C1FE86FEA6BBFDE530677F0D97D11D49F7A8443D0822E506A9F4614E011E2A94838FF88CD68C8BB7C5C6424CFFFFFFFFFFFFFFFF , params_g = 2 , params_bits = 8192 } tls-1.4.1/Network/TLS/Cap.hs0000644000000000000000000000064713137673636013665 0ustar0000000000000000-- | -- Module : Network.TLS.Cap -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Cap ( hasHelloExtensions , hasExplicitBlockIV ) where import Network.TLS.Types hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool hasHelloExtensions ver = ver >= SSL3 hasExplicitBlockIV ver = ver >= TLS11 tls-1.4.1/Network/TLS/Struct.hs0000644000000000000000000004542113240574164014434 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} -- | -- Module : Network.TLS.Struct -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Struct module contains all definitions and values of the TLS protocol -- {-# LANGUAGE CPP #-} module Network.TLS.Struct ( Version(..) , ConnectionEnd(..) , CipherType(..) , CipherData(..) , ExtensionID , ExtensionRaw(..) , CertificateType(..) , 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 qualified Data.ByteString as B (length) import Data.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Exception (Exception(..)) import Network.TLS.Types import Network.TLS.Crypto import Network.TLS.Util.Serialization import Network.TLS.Imports #if MIN_VERSION_mtl(2,2,1) #else import Control.Monad.Error #endif data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD data CipherData = CipherData { cipherDataContent :: ByteString , cipherDataMAC :: Maybe ByteString , cipherDataPadding :: Maybe ByteString } 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 | HashIntrinsic | HashOther Word8 deriving (Show,Eq) data SignatureAlgorithm = SignatureAnonymous | SignatureRSA | SignatureDSS | SignatureECDSA | SignatureRSApssSHA256 | SignatureRSApssSHA384 | SignatureRSApssSHA512 | SignatureEd25519 | SignatureEd448 | SignatureOther Word8 deriving (Show,Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) type Signature = ByteString data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature deriving (Show,Eq) data ProtocolType = ProtocolType_ChangeCipherSpec | ProtocolType_Alert | ProtocolType_Handshake | ProtocolType_AppData | ProtocolType_DeprecatedHandshake deriving (Eq, Show) -- | TLSError that might be returned through the TLS stack data TLSError = Error_Misc String -- ^ mainly for instance of Error | Error_Protocol (String, Bool, AlertDescription) | Error_Certificate String | Error_HandshakePolicy String -- ^ handshake policy failed. | Error_EOF | Error_Packet String | Error_Packet_unexpected String String | Error_Packet_Parsing String deriving (Eq, Show, Typeable) #if MIN_VERSION_mtl(2,2,1) #else instance Error TLSError where noMsg = Error_Misc "" strMsg = Error_Misc #endif instance Exception TLSError -- | TLS Exceptions related to bad user usage or -- asynchronous errors data TLSException = Terminated Bool String TLSError -- ^ Early termination exception with the reason -- and the error associated | HandshakeFailed TLSError -- ^ Handshake failed for the reason attached | ConnectionNotEstablished -- ^ Usage error when the connection has not been established -- and the user is trying to send or receive data deriving (Show,Eq,Typeable) instance Exception TLSException data Packet = Handshake [Handshake] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Show,Eq) data Header = Header ProtocolType Version Word16 deriving (Show,Eq) newtype ServerRandom = ServerRandom { unServerRandom :: ByteString } deriving (Show, Eq) newtype ClientRandom = ClientRandom { unClientRandom :: ByteString } deriving (Show, Eq) newtype Session = Session (Maybe SessionID) deriving (Show, Eq) type FinishedData = ByteString type ExtensionID = Word16 data ExtensionRaw = ExtensionRaw ExtensionID ByteString deriving (Eq) instance Show ExtensionRaw where show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs ++ "" constrRandom32 :: (ByteString -> a) -> ByteString -> Maybe a constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing serverRandom :: ByteString -> Maybe ServerRandom serverRandom l = constrRandom32 ServerRandom l clientRandom :: ByteString -> 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 deriving (Show,Eq) newtype BigNum = BigNum ByteString deriving (Show,Eq) bigNumToInteger :: BigNum -> Integer bigNumToInteger (BigNum b) = os2ip b bigNumFromInteger :: Integer -> BigNum bigNumFromInteger i = BigNum $ i2osp i data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum , serverDHParams_y :: BigNum } deriving (Show,Eq) serverDHParamsFrom :: DHParams -> DHPublic -> ServerDHParams serverDHParamsFrom params dhPub = ServerDHParams (bigNumFromInteger $ dhParamsGetP params) (bigNumFromInteger $ dhParamsGetG params) (bigNumFromInteger $ dhUnwrapPublic dhPub) serverDHParamsToParams :: ServerDHParams -> DHParams serverDHParamsToParams serverParams = dhParams (bigNumToInteger $ serverDHParams_p serverParams) (bigNumToInteger $ serverDHParams_g serverParams) serverDHParamsToPublic :: ServerDHParams -> DHPublic serverDHParamsToPublic serverParams = dhPublic (bigNumToInteger $ serverDHParams_y serverParams) data ServerECDHParams = ServerECDHParams Group GroupPublic deriving (Show,Eq) data ServerRSAParams = ServerRSAParams { rsa_modulus :: Integer , rsa_exponent :: Integer } deriving (Show,Eq) data ServerKeyXchgAlgorithmData = SKX_DH_Anon ServerDHParams | SKX_DHE_DSS ServerDHParams DigitallySigned | SKX_DHE_RSA ServerDHParams DigitallySigned | SKX_ECDHE_RSA ServerECDHParams DigitallySigned | SKX_ECDHE_ECDSA ServerECDHParams DigitallySigned | SKX_RSA (Maybe ServerRSAParams) | SKX_DH_DSS (Maybe ServerRSAParams) | SKX_DH_RSA (Maybe ServerRSAParams) | SKX_Unparsed ByteString -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. | SKX_Unknown ByteString deriving (Show,Eq) data ClientKeyXchgAlgorithmData = CKX_RSA ByteString | CKX_DH DHPublic | CKX_ECDH ByteString deriving (Show,Eq) type DeprecatedRecord = ByteString data Handshake = ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] | Certificates CertificateChain | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName] | CertVerify DigitallySigned | Finished FinishedData deriving (Show,Eq) packetType :: Packet -> ProtocolType packetType (Handshake _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData typeOfHandshake :: Handshake -> HandshakeType typeOfHandshake ClientHello{} = HandshakeType_ClientHello typeOfHandshake ServerHello{} = HandshakeType_ServerHello typeOfHandshake Certificates{} = HandshakeType_Certificate typeOfHandshake HelloRequest = HandshakeType_HelloRequest typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg typeOfHandshake CertRequest{} = HandshakeType_CertRequest typeOfHandshake CertVerify{} = HandshakeType_CertVerify typeOfHandshake Finished{} = HandshakeType_Finished numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) numericalVer SSL3 = (3, 0) numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3) 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 valToType 0 = Just HandshakeType_HelloRequest valToType 1 = Just HandshakeType_ClientHello valToType 2 = Just HandshakeType_ServerHello valToType 11 = Just HandshakeType_Certificate valToType 12 = Just HandshakeType_ServerKeyXchg valToType 13 = Just HandshakeType_CertRequest valToType 14 = Just HandshakeType_ServerHelloDone valToType 15 = Just HandshakeType_CertVerify valToType 16 = Just HandshakeType_ClientKeyXchg valToType 20 = Just HandshakeType_Finished valToType _ = Nothing instance TypeValuable AlertLevel where valOfType AlertLevel_Warning = 1 valOfType AlertLevel_Fatal = 2 valToType 1 = Just AlertLevel_Warning valToType 2 = Just AlertLevel_Fatal valToType _ = Nothing instance TypeValuable AlertDescription where valOfType CloseNotify = 0 valOfType UnexpectedMessage = 10 valOfType BadRecordMac = 20 valOfType DecryptionFailed = 21 valOfType RecordOverflow = 22 valOfType DecompressionFailure = 30 valOfType HandshakeFailure = 40 valOfType BadCertificate = 42 valOfType UnsupportedCertificate = 43 valOfType CertificateRevoked = 44 valOfType CertificateExpired = 45 valOfType CertificateUnknown = 46 valOfType IllegalParameter = 47 valOfType UnknownCa = 48 valOfType AccessDenied = 49 valOfType DecodeError = 50 valOfType DecryptError = 51 valOfType ExportRestriction = 60 valOfType ProtocolVersion = 70 valOfType InsufficientSecurity = 71 valOfType InternalError = 80 valOfType InappropriateFallback = 86 valOfType UserCanceled = 90 valOfType NoRenegotiation = 100 valOfType 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 HashIntrinsic = 8 valOfType (HashOther i) = i valToType 0 = Just HashNone valToType 1 = Just HashMD5 valToType 2 = Just HashSHA1 valToType 3 = Just HashSHA224 valToType 4 = Just HashSHA256 valToType 5 = Just HashSHA384 valToType 6 = Just HashSHA512 valToType 8 = Just HashIntrinsic valToType i = Just (HashOther i) instance TypeValuable SignatureAlgorithm where valOfType SignatureAnonymous = 0 valOfType SignatureRSA = 1 valOfType SignatureDSS = 2 valOfType SignatureECDSA = 3 valOfType SignatureRSApssSHA256 = 4 valOfType SignatureRSApssSHA384 = 5 valOfType SignatureRSApssSHA512 = 6 valOfType SignatureEd25519 = 7 valOfType SignatureEd448 = 8 valOfType (SignatureOther i) = i valToType 0 = Just SignatureAnonymous valToType 1 = Just SignatureRSA valToType 2 = Just SignatureDSS valToType 3 = Just SignatureECDSA valToType 4 = Just SignatureRSApssSHA256 valToType 5 = Just SignatureRSApssSHA384 valToType 6 = Just SignatureRSApssSHA512 valToType 7 = Just SignatureEd25519 valToType 8 = Just SignatureEd448 valToType i = Just (SignatureOther i) instance EnumSafe16 Group where fromEnumSafe16 P256 = 23 fromEnumSafe16 P384 = 24 fromEnumSafe16 P521 = 25 fromEnumSafe16 X25519 = 29 fromEnumSafe16 X448 = 30 fromEnumSafe16 FFDHE2048 = 256 fromEnumSafe16 FFDHE3072 = 257 fromEnumSafe16 FFDHE4096 = 258 fromEnumSafe16 FFDHE6144 = 259 fromEnumSafe16 FFDHE8192 = 260 toEnumSafe16 23 = Just P256 toEnumSafe16 24 = Just P384 toEnumSafe16 25 = Just P521 toEnumSafe16 29 = Just X25519 toEnumSafe16 30 = Just X448 toEnumSafe16 256 = Just FFDHE2048 toEnumSafe16 257 = Just FFDHE3072 toEnumSafe16 258 = Just FFDHE4096 toEnumSafe16 259 = Just FFDHE6144 toEnumSafe16 260 = Just FFDHE8192 toEnumSafe16 _ = Nothing tls-1.4.1/Network/TLS/Core.hs0000644000000000000000000001147313240574164014040 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 -- * Application Layer 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 qualified Data.ByteString.Lazy as L import qualified Control.Exception as E import Control.Monad.State.Strict -- | notify the context that this side wants to close connection. -- this is important that it is called before closing the handle, otherwise -- the session might not be resumable (for version < TLS1.2). -- -- this doesn't actually close the handle bye :: MonadIO m => Context -> m () bye ctx = do eof <- liftIO $ ctxEOF ctx unless eof $ sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon. getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol 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 pkt <- withReadLock ctx $ recvPacket ctx either onError process pkt where onError Error_EOF = -- Not really an error. return B.empty 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{}]) = handshakeWith ctx ch >> recvData ctx process (Handshake [hr@HelloRequest]) = handshakeWith 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.4.1/Network/TLS/Context.hs0000644000000000000000000001425413240574164014574 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.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 Control.Concurrent.MVar import Control.Monad.State.Strict import Data.IORef -- deprecated imports #ifdef INCLUDE_NETWORK import Network.Socket (Socket) #endif import System.IO (Handle) class TLSParams a where getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> Handshake -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams = ( clientSupported cparams , clientShared cparams , clientDebug cparams ) getTLSRole _ = ClientRole doHandshake = handshakeClient doHandshakeWith = handshakeClientWith instance TLSParams ServerParams where getTLSCommonParams sparams = ( serverSupported sparams , serverShared sparams , serverDebug sparams ) getTLSRole _ = ServerRole 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 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 , 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.4.1/Network/TLS/Context/Internal.hs0000644000000000000000000002010313240574164016336 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 Network.TLS.Imports import qualified Data.ByteString as B import Control.Concurrent.MVar import Control.Monad.State.Strict import Control.Exception (throwIO, Exception()) import Data.IORef import Data.Tuple -- | Information related to a running context, e.g. current cipher data Information = Information { infoVersion :: Version , infoCipher :: Cipher , infoCompression :: Compression , infoMasterSecret :: Maybe ByteString , 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 , 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 -> ByteString -> IO () contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b contextRecv :: Context -> Int -> IO ByteString contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz ctxEOF :: Context -> IO Bool ctxEOF ctx = readIORef $ ctxEOF_ ctx ctxHasSSLv2ClientHello :: Context -> IO Bool ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx ctxDisableSSLv2ClientHello :: Context -> IO () ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True ctxEstablished :: Context -> IO 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 <$> 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 ByteString getStateRNG ctx n = usingState_ ctx $ genRandom n withReadLock :: Context -> IO a -> IO a withReadLock ctx f = withMVar (ctxLockRead ctx) (const f) withWriteLock :: Context -> IO a -> IO a withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f) withRWLock :: Context -> IO a -> IO a withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f withStateLock :: Context -> IO a -> IO a withStateLock ctx f = withMVar (ctxLockState ctx) (const f) tls-1.4.1/Network/TLS/Credentials.hs0000644000000000000000000001674013246063515015406 0ustar0000000000000000-- | -- Module : Network.TLS.Credentials -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE CPP #-} module Network.TLS.Credentials ( Credential , Credentials(..) , credentialLoadX509 , credentialLoadX509FromMemory , credentialLoadX509Chain , credentialLoadX509ChainFromMemory , credentialsFindForSigning , credentialsFindForDecrypting , credentialsListSigningAlgorithms , credentialPublicPrivateKeys , credentialMatchesHashSignatures ) where import Network.TLS.Crypto import Network.TLS.X509 import Network.TLS.Imports import Data.X509.File import Data.X509.Memory import Data.X509 import qualified Data.X509 as X509 import qualified Network.TLS.Struct as TLS type Credential = (CertificateChain, PrivKey) newtype Credentials = Credentials [Credential] #if MIN_VERSION_base(4,9,0) instance Semigroup Credentials where Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2) #endif instance Monoid Credentials where mempty = Credentials [] #if !(MIN_VERSION_base(4,11,0)) mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2) #endif -- | try to create a new credential object from a public certificate -- and the associated private key that are stored on the filesystem -- in PEM format. credentialLoadX509 :: FilePath -- ^ public certificate (X.509 format) -> FilePath -- ^ private key associated -> IO (Either String Credential) credentialLoadX509 certFile = credentialLoadX509Chain certFile [] -- | similar to 'credentialLoadX509' but take the certificate -- and private key from memory instead of from the filesystem. credentialLoadX509FromMemory :: ByteString -> ByteString -> Either String Credential credentialLoadX509FromMemory certData = credentialLoadX509ChainFromMemory certData [] -- | similar to 'credentialLoadX509' but also allow specifying chain -- certificates. credentialLoadX509Chain :: FilePath -- ^ public certificate (X.509 format) -> [FilePath] -- ^ chain certificates (X.509 format) -> FilePath -- ^ private key associated -> IO (Either String Credential) credentialLoadX509Chain certFile chainFiles privateFile = do x509 <- readSignedObject certFile chains <- mapM readSignedObject chainFiles keys <- readKeyFile privateFile case keys of [] -> return $ Left "no keys found" (k:_) -> return $ Right (CertificateChain . concat $ x509 : chains, k) -- | similar to 'credentialLoadX509FromMemory' but also allow -- specifying chain certificates. credentialLoadX509ChainFromMemory :: ByteString -> [ByteString] -> ByteString -> Either String Credential credentialLoadX509ChainFromMemory certData chainData privateData = do let x509 = readSignedObjectFromMemory certData chains = map readSignedObjectFromMemory chainData keys = readKeyFileFromMemory privateData in case keys of [] -> Left "no keys found" (k:_) -> Right (CertificateChain . concat $ x509 : chains, k) credentialsListSigningAlgorithms :: Credentials -> [DigitalSignatureAlg] credentialsListSigningAlgorithms (Credentials l) = mapMaybe credentialCanSign l credentialsFindForSigning :: DigitalSignatureAlg -> Credentials -> Maybe Credential credentialsFindForSigning sigAlg (Credentials l) = find forSigning l where forSigning cred = case credentialCanSign cred of Nothing -> False Just sig -> sig == sigAlg credentialsFindForDecrypting :: Credentials -> Maybe Credential credentialsFindForDecrypting (Credentials l) = find forEncrypting l where forEncrypting cred = Just () == credentialCanDecrypt cred -- here we assume that only RSA is supported for key encipherment (encryption/decryption) -- we keep the same construction as 'credentialCanSign', returning a Maybe of () in case -- this change in future. credentialCanDecrypt :: Credential -> Maybe () credentialCanDecrypt (chain, priv) = case (pub, priv) of (PubKeyRSA _, PrivKeyRSA _) -> case extensionGet (certExtensions cert) of Nothing -> Just () Just (ExtKeyUsage flags) | KeyUsage_keyEncipherment `elem` flags -> Just () | otherwise -> Nothing _ -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain credentialCanSign :: Credential -> Maybe DigitalSignatureAlg credentialCanSign (chain, priv) = case extensionGet (certExtensions cert) of Nothing -> findDigitalSignatureAlg (pub, priv) Just (ExtKeyUsage flags) | KeyUsage_digitalSignature `elem` flags -> findDigitalSignatureAlg (pub, priv) | otherwise -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey) credentialPublicPrivateKeys (chain, priv) = pub `seq` (pub, priv) where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm getHashSignature signed = case signedAlg $ getSigned signed of SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSS hashAlg SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA256) SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA384) SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA512) _ -> Nothing where convertHash sig X509.HashMD5 = Just (TLS.HashMD5 , sig) convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1 , sig) convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig) convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig) convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig) convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig) convertHash _ _ = Nothing -- | Checks whether certificates in the chain comply with a list of -- hash/signature algorithm pairs. Currently the verification applies only -- to the leaf certificate, if it is not self-signed. This may be extended -- to additional chain elements in the future. credentialMatchesHashSignatures :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool credentialMatchesHashSignatures hashSigs (chain, _) = case chain of CertificateChain [] -> True CertificateChain (leaf:_) -> isSelfSigned leaf || matchHashSig leaf where matchHashSig signed = case getHashSignature signed of Nothing -> False Just hs -> hs `elem` hashSigs isSelfSigned signed = let cert = signedObject $ getSigned signed in certSubjectDN cert == certIssuerDN cert tls-1.4.1/Network/TLS/Backend.hs0000644000000000000000000000702213240574164014472 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Backend -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- A Backend represents a unified way to do IO on different -- types without burdening our calling API with multiple -- ways to initialize a new context. -- -- Typically, a backend provides: -- * a way to read data -- * a way to write data -- * a way to close the stream -- * a way to flush the stream -- module Network.TLS.Backend ( HasBackend(..) , Backend(..) ) where import Network.TLS.Imports import qualified Data.ByteString as B import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) #ifdef INCLUDE_NETWORK import qualified Network.Socket as Network (Socket, close) import qualified Network.Socket.ByteString as Network #endif #ifdef INCLUDE_HANS import qualified Data.ByteString.Lazy as L import qualified Hans.NetworkStack as Hans #endif -- | Connection IO backend data Backend = Backend { backendFlush :: IO () -- ^ Flush the connection sending buffer, if any. , backendClose :: IO () -- ^ Close the connection. , backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection. , backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection. } class HasBackend a where initializeBackend :: a -> IO () getBackend :: a -> Backend instance HasBackend Backend where initializeBackend _ = return () getBackend = id #if defined(__GLASGOW_HASKELL__) && WINDOWS -- Socket recv and accept calls on Windows platform cannot be interrupted when compiled with -threaded. -- See https://ghc.haskell.org/trac/ghc/ticket/5797 for details. -- The following enables simple workaround #define SOCKET_ACCEPT_RECV_WORKAROUND #endif safeRecv :: Network.Socket -> Int -> IO ByteString #ifndef SOCKET_ACCEPT_RECV_WORKAROUND safeRecv = Network.recv #else safeRecv s buf = do var <- newEmptyMVar forkIO $ Network.recv s buf `E.catch` (\(_::IOException) -> return S8.empty) >>= putMVar var takeMVar var #endif #ifdef INCLUDE_NETWORK instance HasBackend Network.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll where recvAll n = B.concat <$> loop n where loop 0 = return [] loop left = do r <- safeRecv sock left if B.null r then return [] else 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 <$> 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.4.1/Network/TLS/Crypto.hs0000644000000000000000000003045713240574164014433 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Crypto ( HashContext , HashCtx , hashInit , hashUpdate , hashUpdateSSL , hashFinal , module Network.TLS.Crypto.DH , module Network.TLS.Crypto.IES , module Network.TLS.Crypto.Types -- * Hash , hash , Hash(..) , hashName , hashDigestSize , hashBlockSize -- * key exchange generic interface , PubKey(..) , PrivKey(..) , PublicKey , PrivateKey , SignatureParams(..) , findDigitalSignatureAlg , findFiniteFieldGroup , kxEncrypt , kxDecrypt , kxSign , kxVerify , KxError(..) , RSAEncoding(..) ) where import qualified Crypto.Hash as H import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) import Crypto.Random import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.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 qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Number.Serialize (os2ip) import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..), SerializedPoint(..)) import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types import Network.TLS.Imports import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding (DER(..), BER(..)) {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-} type PrivateKey = PrivKey data KxError = RSAError RSA.Error | KxUnsupported deriving (Show) findDigitalSignatureAlg :: (PubKey, PrivKey) -> Maybe DigitalSignatureAlg findDigitalSignatureAlg keyPair = case keyPair of (PubKeyRSA _, PrivKeyRSA _) -> Just RSA (PubKeyDSA _, PrivKeyDSA _) -> Just DSS --(PubKeyECDSA _, PrivKeyECDSA _) -> Just ECDSA _ -> Nothing findFiniteFieldGroup :: DH.Params -> Maybe Group findFiniteFieldGroup params = lookup (pg params) table where pg (DH.Params p g _) = (p, g) table = [ (pg prms, grp) | grp <- availableFFGroups , let Just prms = dhParamsForGroup grp ] -- functions to use the hidden class. hashInit :: Hash -> HashContext hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5) hashInit SHA1 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA1) hashInit SHA224 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA224) hashInit SHA256 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA256) hashInit SHA384 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA384) hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512) hashInit SHA1_MD5 = HashContextSSL H.hashInit H.hashInit hashUpdate :: HashContext -> B.ByteString -> HashCtx hashUpdate (HashContext (ContextSimple h)) b = HashContext $ ContextSimple (H.hashUpdate h b) hashUpdate (HashContextSSL sha1Ctx md5Ctx) b = HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b) hashUpdateSSL :: HashCtx -> (B.ByteString,B.ByteString) -- ^ (for the md5 context, for the sha1 context) -> HashCtx hashUpdateSSL (HashContext _) _ = error "internal error: update SSL without a SSL Context" hashUpdateSSL (HashContextSSL sha1Ctx md5Ctx) (b1,b2) = HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) hashFinal :: HashCtx -> B.ByteString hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) = B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 deriving (Show,Eq) data HashContext = HashContext ContextSimple | HashContextSSL (H.Context H.SHA1) (H.Context H.MD5) instance Show HashContext where show _ = "hash-context" data ContextSimple = forall alg . H.HashAlgorithm alg => ContextSimple (H.Context alg) type HashCtx = HashContext hash :: Hash -> B.ByteString -> B.ByteString hash MD5 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.MD5) $ b hash SHA1 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA1) $ b hash SHA224 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA224) $ b hash SHA256 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA256) $ b hash SHA384 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA384) $ b hash SHA512 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA512) $ b hash SHA1_MD5 b = B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)] where sha1Hash :: B.ByteString -> H.Digest H.SHA1 sha1Hash = H.hash md5Hash :: B.ByteString -> H.Digest H.MD5 md5Hash = H.hash hashName :: Hash -> String hashName = show hashDigestSize :: Hash -> Int hashDigestSize MD5 = 16 hashDigestSize SHA1 = 20 hashDigestSize SHA224 = 28 hashDigestSize SHA256 = 32 hashDigestSize SHA384 = 48 hashDigestSize SHA512 = 64 hashDigestSize SHA1_MD5 = 36 hashBlockSize :: Hash -> Int hashBlockSize MD5 = 64 hashBlockSize SHA1 = 64 hashBlockSize SHA224 = 64 hashBlockSize SHA256 = 64 hashBlockSize SHA384 = 128 hashBlockSize SHA512 = 128 hashBlockSize SHA1_MD5 = 64 {- key exchange methods encrypt and decrypt for each supported algorithm -} generalizeRSAError :: Either RSA.Error a -> Either KxError a generalizeRSAError (Left e) = Left (RSAError e) generalizeRSAError (Right x) = Right x kxEncrypt :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq) -- Signature algorithm and associated parameters. -- -- FIXME add RSAPSSParams, Ed25519Params, Ed448Params data SignatureParams = RSAParams Hash RSAEncoding | DSSParams | ECDSAParams Hash deriving (Show,Eq) -- Verify that the signature matches the given message, using the -- public key. -- kxVerify :: PublicKey -> SignatureParams -> ByteString -> ByteString -> Bool kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign kxVerify (PubKeyDSA pk) DSSParams msg signBS = case dsaToSignature signBS of Just sig -> DSA.verify H.SHA1 pk sig msg _ -> False where dsaToSignature :: ByteString -> Maybe DSA.Signature dsaToSignature b = case decodeASN1' BER b of Left _ -> Nothing Right asn1 -> case asn1 of Start Sequence:IntVal r:IntVal s:End Sequence:_ -> Just DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } _ -> Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ do -- get the curve name and the public key data (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 input /= 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 = ECC.curveSizeBits curve bytes = (bits + 7) `div` 8 kxVerify _ _ _ _ = False -- Sign the given message using the private key. -- kxSign :: MonadRandom r => PrivateKey -> SignatureParams -> ByteString -> r (Either KxError ByteString) kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApkcs1) msg = generalizeRSAError <$> rsaSignHash hashAlg pk msg kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApss) msg = generalizeRSAError <$> rsapssSignHash hashAlg pk msg kxSign (PrivKeyDSA pk) DSSParams msg = do sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign) where dsaSequence sign = [Start Sequence,IntVal (DSA.sign_r sign),IntVal (DSA.sign_s sign),End Sequence] kxSign _ _ _ = return (Left KxUnsupported) rsaSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) rsaSignHash SHA1_MD5 pk msg = RSA.signSafer noHash pk msg rsaSignHash MD5 pk msg = RSA.signSafer (Just H.MD5) pk msg rsaSignHash SHA1 pk msg = RSA.signSafer (Just H.SHA1) pk msg rsaSignHash SHA224 pk msg = RSA.signSafer (Just H.SHA224) pk msg rsaSignHash SHA256 pk msg = RSA.signSafer (Just H.SHA256) pk msg rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg rsapssSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) rsapssSignHash SHA256 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA256) pk msg rsapssSignHash SHA384 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA384) pk msg rsapssSignHash SHA512 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA512) pk msg rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash" rsaVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsaVerifyHash SHA1_MD5 = RSA.verify noHash rsaVerifyHash MD5 = RSA.verify (Just H.MD5) rsaVerifyHash SHA1 = RSA.verify (Just H.SHA1) rsaVerifyHash SHA224 = RSA.verify (Just H.SHA224) rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256) rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384) rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512) rsapssVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsapssVerifyHash SHA256 = PSS.verify (PSS.defaultPSSParams H.SHA256) rsapssVerifyHash SHA384 = PSS.verify (PSS.defaultPSSParams H.SHA384) rsapssVerifyHash SHA512 = PSS.verify (PSS.defaultPSSParams H.SHA512) rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" noHash :: Maybe H.MD5 noHash = Nothing tls-1.4.1/Network/TLS/Crypto/DH.hs0000644000000000000000000000373713215475646014736 0ustar0000000000000000module Network.TLS.Crypto.DH ( -- * DH types DHParams , DHPublic , DHPrivate , DHKey -- * DH methods , dhPublic , dhPrivate , dhParams , dhParamsGetP , dhParamsGetG , dhGenerateKeyPair , dhGetShared , dhValid , dhUnwrap , dhUnwrapPublic ) where import qualified Crypto.PubKey.DH as DH import Crypto.Number.Basic (numBits) import qualified Data.ByteArray as B import Network.TLS.RNG type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params type DHKey = DH.SharedKey dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber dhPrivate :: Integer -> DHPrivate dhPrivate = DH.PrivateNumber dhParams :: Integer -> Integer -> DHParams dhParams p g = DH.Params p g (numBits p) dhGenerateKeyPair :: MonadRandom r => DHParams -> r (DHPrivate, DHPublic) dhGenerateKeyPair params = do priv <- DH.generatePrivate params let pub = DH.calculatePublic params priv return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey dhGetShared params priv pub = stripLeadingZeros (DH.getShared params priv pub) where -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) premaster secret in SSL/TLS before version 1.3. stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb) -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1. -- This verification is enough when using a safe prime. dhValid :: DHParams -> Integer -> Bool dhValid (DH.Params p _ _) y = 1 < y && y < p - 1 dhUnwrap :: DHParams -> DHPublic -> [Integer] dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p,g,y] dhParamsGetP :: DHParams -> Integer dhParamsGetP (DH.Params p _ _) = p dhParamsGetG :: DHParams -> Integer dhParamsGetG (DH.Params _ g _) = g dhUnwrapPublic :: DHPublic -> Integer dhUnwrapPublic (DH.PublicNumber y) = y tls-1.4.1/Network/TLS/Crypto/IES.hs0000644000000000000000000002703613215475646015061 0ustar0000000000000000-- | -- Module : Network.TLS.Crypto.IES -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown -- module Network.TLS.Crypto.IES ( GroupPublic , GroupPrivate , GroupKey -- * Group methods , groupGenerateKeyPair , groupGetPubShared , groupGetShared , encodeGroupPublic , decodeGroupPublic -- * Compatibility with 'Network.TLS.Crypto.DH' , dhParamsForGroup , dhGroupGenerateKeyPair , dhGroupGetPubShared ) where import Control.Arrow import Crypto.ECC import Crypto.Error import Crypto.Number.Generate import Crypto.PubKey.DH hiding (generateParams) import Crypto.PubKey.ECIES import qualified Data.ByteArray as B import Data.Proxy import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Util.Serialization (os2ip,i2ospOf_) data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) | GroupPri_P384 (Scalar Curve_P384R1) | GroupPri_P521 (Scalar Curve_P521R1) | GroupPri_X255 (Scalar Curve_X25519) | GroupPri_X448 (Scalar Curve_X448) | GroupPri_FFDHE2048 PrivateNumber | GroupPri_FFDHE3072 PrivateNumber | GroupPri_FFDHE4096 PrivateNumber | GroupPri_FFDHE6144 PrivateNumber | GroupPri_FFDHE8192 PrivateNumber deriving (Eq, Show) data GroupPublic = GroupPub_P256 (Point Curve_P256R1) | GroupPub_P384 (Point Curve_P384R1) | GroupPub_P521 (Point Curve_P521R1) | GroupPub_X255 (Point Curve_X25519) | GroupPub_X448 (Point Curve_X448) | GroupPub_FFDHE2048 PublicNumber | GroupPub_FFDHE3072 PublicNumber | GroupPub_FFDHE4096 PublicNumber | GroupPub_FFDHE6144 PublicNumber | GroupPub_FFDHE8192 PublicNumber deriving (Eq, Show) type GroupKey = SharedSecret p256 :: Proxy Curve_P256R1 p256 = Proxy p384 :: Proxy Curve_P384R1 p384 = Proxy p521 :: Proxy Curve_P521R1 p521 = Proxy x25519 :: Proxy Curve_X25519 x25519 = Proxy x448 :: Proxy Curve_X448 x448 = Proxy dhParamsForGroup :: Group -> Maybe Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096 dhParamsForGroup FFDHE6144 = Just ffdhe6144 dhParamsForGroup FFDHE8192 = Just ffdhe8192 dhParamsForGroup _ = Nothing groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic) groupGenerateKeyPair P256 = (GroupPri_P256,GroupPub_P256) `fs` curveGenerateKeyPair p256 groupGenerateKeyPair P384 = (GroupPri_P384,GroupPub_P384) `fs` curveGenerateKeyPair p384 groupGenerateKeyPair P521 = (GroupPri_P521,GroupPub_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 = (GroupPri_X255,GroupPub_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 = (GroupPri_X448,GroupPub_X448) `fs` curveGenerateKeyPair x448 groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048 groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072 groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096 groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144 groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192 dhGroupGenerateKeyPair :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096) dhGroupGenerateKeyPair FFDHE6144 = addParams ffdhe6144 (gen' ffdhe6144 exp6144) dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b) fs :: MonadRandom r => (Scalar a -> GroupPrivate, Point a -> GroupPublic) -> r (KeyPair a) -> r (GroupPrivate, GroupPublic) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) gen :: MonadRandom r => Params -> Int -> (PrivateNumber -> GroupPrivate) -> (PublicNumber -> GroupPublic) -> r (GroupPrivate, GroupPublic) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits gen' :: MonadRandom r => Params -> Int -> r (PrivateNumber, PublicNumber) gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits groupGetPubShared :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) groupGetPubShared (GroupPub_P256 pub) = fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub groupGetPubShared (GroupPub_P384 pub) = fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub groupGetPubShared (GroupPub_P521 pub) = fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub groupGetPubShared (GroupPub_X255 pub) = fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub groupGetPubShared (GroupPub_X448 pub) = fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048 groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072 groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096 groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144 groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192 dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey)) dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub dhGroupGetPubShared _ _ = return Nothing getPubShared :: MonadRandom r => Params -> Int -> PublicNumber -> (PublicNumber -> GroupPublic) -> r (Maybe (GroupPublic, GroupKey)) getPubShared params expBits pub pubTag | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits let mypub = calculatePublic params mypri let SharedKey share = getShared params mypri pub return $ Just (pubTag mypub, SharedSecret share) getPubShared' :: MonadRandom r => Params -> Int -> PublicNumber -> r (Maybe (PublicNumber, SharedKey)) getPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits let share = stripLeadingZeros (getShared params mypri pub) return $ Just (calculatePublic params mypri, SharedKey share) groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri groupGetShared _ _ = Nothing calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret calcShared params pub pri | valid params pub = Just $ SharedSecret share | otherwise = Nothing where SharedKey share = getShared params pri pub encodeGroupPublic :: GroupPublic -> ByteString encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p enc :: Params -> PublicNumber -> ByteString enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1. valid :: Params -> PublicNumber -> Bool valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 -- strips leading zeros from the result of getShared, as required -- for DH(E) premaster secret in SSL/TLS before version 1.3. stripLeadingZeros :: SharedKey -> B.ScrubbedBytes stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber generatePriv e = PrivateNumber <$> generateParams e (Just SetHighest) False -- Short exponent bit sizes from RFC 7919 appendix A, rounded to next -- multiple of 16 bits, i.e. going through a function like: -- let shortExp n = head [ e | i <- [1..], let e = n + i, e `mod` 16 == 0 ] exp2048 :: Int exp3072 :: Int exp4096 :: Int exp6144 :: Int exp8192 :: Int exp2048 = 240 -- shortExp 225 exp3072 = 288 -- shortExp 275 exp4096 = 336 -- shortExp 325 exp6144 = 384 -- shortExp 375 exp8192 = 416 -- shortExp 400 tls-1.4.1/Network/TLS/Crypto/Types.hs0000644000000000000000000000152413215475646015537 0ustar0000000000000000-- | -- Module : Network.TLS.Crypto.Types -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown -- module Network.TLS.Crypto.Types where data Group = P256 | P384 | P521 | X25519 | X448 | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 deriving (Eq, Show) availableFFGroups :: [Group] availableFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192] availableECGroups :: [Group] availableECGroups = [P256,P384,P521,X25519,X448] availableGroups :: [Group] availableGroups = availableECGroups ++ availableFFGroups -- Digital signature algorithm, in close relation to public/private key types -- and cipher key exchange. data DigitalSignatureAlg = RSA | DSS | ECDSA | Ed25519 | Ed448 deriving (Show, Eq) tls-1.4.1/Network/TLS/ErrT.hs0000644000000000000000000000121313100036227013777 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.4.1/Network/TLS/Extension.hs0000644000000000000000000003040113240574732015115 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_ApplicationLayerProtocolNegotiation , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_Heartbeat , extensionID_SignatureAlgorithms -- all implemented extensions , ServerNameType(..) , ServerName(..) , MaxFragmentLength(..) , MaxFragmentEnum(..) , SecureRenegotiation(..) , ApplicationLayerProtocolNegotiation(..) , NegotiatedGroups(..) , Group(..) , EcPointFormatsSupported(..) , EcPointFormat(..) , SessionTicket(..) , HeartBeat(..) , HeartBeatMode(..) , SignatureAlgorithms(..) ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Network.TLS.Struct (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm) import Network.TLS.Crypto.Types 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_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SRP , extensionID_SignatureAlgorithms , extensionID_SRTP , extensionID_Heartbeat , extensionID_ApplicationLayerProtocolNegotiation , extensionID_StatusRequestv2 , extensionID_SignedCertificateTimestamp , extensionID_ClientCertificateType , extensionID_ServerCertificateType , extensionID_Padding , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket , extensionID_SecureRenegotiation :: ExtensionID extensionID_ServerName = 0x0 -- RFC6066 extensionID_MaxFragmentLength = 0x1 -- RFC6066 extensionID_ClientCertificateUrl = 0x2 -- RFC6066 extensionID_TrustedCAKeys = 0x3 -- RFC6066 extensionID_TruncatedHMAC = 0x4 -- RFC6066 extensionID_StatusRequest = 0x5 -- RFC6066 extensionID_UserMapping = 0x6 -- RFC4681 extensionID_ClientAuthz = 0x7 -- RFC5878 extensionID_ServerAuthz = 0x8 -- RFC5878 extensionID_CertType = 0x9 -- RFC6091 extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3 extensionID_EcPointFormats = 0xb -- RFC4492 extensionID_SRP = 0xc -- RFC5054 extensionID_SignatureAlgorithms = 0xd -- RFC5246 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_SecureRenegotiation = 0xff01 -- RFC5746 definedExtensions :: [ExtensionID] definedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ClientCertificateUrl , extensionID_TrustedCAKeys , extensionID_TruncatedHMAC , extensionID_StatusRequest , extensionID_UserMapping , extensionID_ClientAuthz , extensionID_ServerAuthz , extensionID_CertType , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SRP , extensionID_SignatureAlgorithms , extensionID_SRTP , extensionID_Heartbeat , extensionID_ApplicationLayerProtocolNegotiation , extensionID_StatusRequestv2 , extensionID_SignedCertificateTimestamp , extensionID_ClientCertificateType , extensionID_ServerCertificateType , extensionID_Padding , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket , extensionID_SecureRenegotiation ] -- | all supported extensions by the implementation supportedExtensions :: [ExtensionID] supportedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_ApplicationLayerProtocolNegotiation , extensionID_SecureRenegotiation , extensionID_NegotiatedGroups , 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 newtype ServerName = ServerName [ServerNameType] deriving (Show,Eq) data ServerNameType = ServerNameHostName HostName | ServerNameOther (Word8, ByteString) deriving (Show,Eq) instance Extension ServerName where extensionID _ = extensionID_ServerName extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque extensionDecode _ = runGetMaybe (getWord16 >>= \len -> ServerName <$> getList (fromIntegral len) getServerName) 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 newtype 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 -- | Application Layer Protocol Negotiation (ALPN) newtype ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension ApplicationLayerProtocolNegotiation where extensionID _ = extensionID_ApplicationLayerProtocolNegotiation extensionEncode (ApplicationLayerProtocolNegotiation bytes) = runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes extensionDecode _ = runGetMaybe (ApplicationLayerProtocolNegotiation <$> getALPN) where getALPN = do _ <- getWord16 getALPN' getALPN' = do avail <- remaining case avail of 0 -> return [] _ -> (:) <$> getOpaque8 <*> getALPN' newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) -- on decode, filter all unknown curves instance Extension NegotiatedGroups where extensionID _ = extensionID_NegotiatedGroups extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups extensionDecode _ = runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16) newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) data EcPointFormat = EcPointFormat_Uncompressed | EcPointFormat_AnsiX962_compressed_prime | EcPointFormat_AnsiX962_compressed_char2 deriving (Show,Eq) instance EnumSafe8 EcPointFormat where fromEnumSafe8 EcPointFormat_Uncompressed = 0 fromEnumSafe8 EcPointFormat_AnsiX962_compressed_prime = 1 fromEnumSafe8 EcPointFormat_AnsiX962_compressed_char2 = 2 toEnumSafe8 0 = Just EcPointFormat_Uncompressed toEnumSafe8 1 = Just EcPointFormat_AnsiX962_compressed_prime toEnumSafe8 2 = Just EcPointFormat_AnsiX962_compressed_char2 toEnumSafe8 _ = Nothing -- on decode, filter all unknown formats instance Extension EcPointFormatsSupported where extensionID _ = extensionID_EcPointFormats extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats extensionDecode _ = runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8) data SessionTicket = SessionTicket deriving (Show,Eq) instance Extension SessionTicket where extensionID _ = extensionID_SessionTicket extensionEncode SessionTicket{} = runPut $ return () extensionDecode _ = runGetMaybe (return SessionTicket) newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq) data HeartBeatMode = HeartBeat_PeerAllowedToSend | HeartBeat_PeerNotAllowedToSend deriving (Show,Eq) instance EnumSafe8 HeartBeatMode where fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1 fromEnumSafe8 HeartBeat_PeerNotAllowedToSend = 2 toEnumSafe8 1 = Just HeartBeat_PeerAllowedToSend toEnumSafe8 2 = Just HeartBeat_PeerNotAllowedToSend toEnumSafe8 _ = Nothing instance Extension HeartBeat where extensionID _ = extensionID_Heartbeat extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 mode extensionDecode _ bs = case runGetMaybe (toEnumSafe8 <$> getWord8) bs of Just (Just mode) -> Just $ HeartBeat mode _ -> Nothing newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq) instance Extension SignatureAlgorithms where extensionID _ = extensionID_SignatureAlgorithms extensionEncode (SignatureAlgorithms algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) >> mapM_ putSignatureHashAlgorithm algs extensionDecode _ = runGetMaybe $ do len <- getWord16 SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) tls-1.4.1/Network/TLS/Handshake.hs0000644000000000000000000000312113240574164015025 0ustar0000000000000000-- | -- Module : Network.TLS.Handshake -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake ( handshake , handshakeWith , handshakeClientWith , handshakeServerWith , handshakeClient , handshakeServer ) where import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.IO import Network.TLS.Util (catchException) import Network.TLS.Imports import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State.Strict import Control.Exception (IOException, catch, 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 ctx $ withRWLock ctx (ctxDoHandshake ctx ctx) -- Handshake when requested by the remote end -- This is called automatically by 'recvData' handshakeWith :: MonadIO m => Context -> Handshake -> m () handshakeWith ctx hs = liftIO $ handleException ctx $ withRWLock ctx $ ctxDoHandshakeWith ctx ctx hs handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception setEstablished ctx False sendPacket ctx (errorToAlert tlserror) `catch` ignoreIOErr handshakeFailed tlserror where ignoreIOErr :: IOException -> IO () ignoreIOErr _ = return () tls-1.4.1/Network/TLS/Handshake/Common.hs0000644000000000000000000001277213240574164016271 0ustar0000000000000000{-# LANGUAGE 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.Compression 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 Network.TLS.Imports import Control.Monad.State.Strict 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 String -> IO a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session newSession ctx | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 | otherwise = return $ Session Nothing -- | when a new handshake is done, wrap up & clean up. handshakeTerminate :: Context -> IO () handshakeTerminate ctx = do session <- usingState_ ctx getSession -- only callback the session established if we have a session case session of Session (Just sessionId) -> do sessionData <- getSessionData ctx 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 :: Context -> Role -> IO () sendChangeCipherAndFinish ctx role = do sendPacket ctx ChangeCipherSpec liftIO $ contextFlush ctx cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role sendPacket ctx (Handshake [Finished cf]) liftIO $ contextFlush ctx recvChangeCipherAndFinish :: Context -> IO () recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher) where expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") data RecvState m = RecvStateNext (Packet -> m (RecvState m)) | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone recvPacketHandshake :: Context -> IO [Handshake] recvPacketHandshake ctx = do pkts <- recvPacket ctx case pkts of Right (Handshake l) -> return l Right x -> 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 sni <- usingState_ ctx getClientSNI 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 , sessionCompression = compressionID $ stCompression tx , sessionClientSNI = sni , sessionSecret = ms } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString extensionLookup toFind = fmap (\(ExtensionRaw _ content) -> content) . find (\(ExtensionRaw eid _) -> eid == toFind) tls-1.4.1/Network/TLS/Handshake/Certificate.hs0000644000000000000000000000240613137673636017265 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.Strict 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.4.1/Network/TLS/Handshake/Key.hs0000644000000000000000000000560313215475646015573 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 , signPrivate , decryptRSA , verifyPublic , generateDHE , generateECDHE , generateECDHEShared , generateFFDHE , generateFFDHEShared ) where import qualified Data.ByteString as B import Network.TLS.Handshake.State import Network.TLS.State (withRNG, getVersion) import Network.TLS.Crypto import Network.TLS.Types import Network.TLS.Context.Internal import Network.TLS.Imports {- 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 signPrivate :: Context -> Role -> SignatureParams -> ByteString -> IO ByteString signPrivate ctx _ params content = do privateKey <- usingHState ctx getLocalPrivateKey usingState_ ctx $ do r <- withRNG $ kxSign privateKey params content case r of Left err -> fail ("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 verifyPublic :: Context -> Role -> SignatureParams -> ByteString -> ByteString -> IO Bool verifyPublic ctx _ params econtent sign = do publicKey <- usingHState ctx getRemotePublicKey return $ kxVerify publicKey params econtent sign generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic) generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp generateECDHEShared :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub tls-1.4.1/Network/TLS/Handshake/Client.hs0000644000000000000000000005511413240574732016255 0ustar0000000000000000{-# LANGUAGE 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 qualified Data.ByteString as B import Control.Monad.State.Strict 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 ctx ClientRole else do sendClientData cparams ctx sendChangeCipherAndFinish ctx ClientRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where ciphers = supportedCiphers $ ctxSupported ctx compressions = supportedCompressions $ ctxSupported ctx getExtensions = sequence [sniExtension ,secureReneg ,alpnExtension ,groupExtension ,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 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 do let sni = fst $ clientServerIdentification cparams usingState_ ctx $ setClientSNI sni return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams sendClientHello = do crand <- ClientRandom <$> getStateRNG ctx 32 let clientSession = Session . (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 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 () PubKeyDSA _ -> 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 <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams ffGroup = findFiniteFieldGroup params srvpub = serverDHParamsToPublic serverParams (clientDHPub, premaster) <- case ffGroup of Nothing -> do groupUsage <- (onCustomFFDHEGroup $ clientHooks cparams) params srvpub `catchException` throwMiscErrorOnException "custom group callback failed" case groupUsage of GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity) GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure) GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) GroupUsageValid -> do (clientDHPriv, clientDHPub) <- generateDHE ctx params let premaster = dhGetShared params clientDHPriv srvpub return (clientDHPub, premaster) Just grp -> do dhePair <- generateFFDHEShared ctx grp srvpub case dhePair of Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) Just pair -> return pair usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster return $ CKX_DH clientDHPub getCKX_ECDHE = do ServerECDHParams _grp srvpub <- usingHState ctx getServerECDHParams ecdhePair <- generateECDHEShared ctx srvpub case ecdhePair of Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure) Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster return $ CKX_ECDH $ encodeGroupPublic clipub -- 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 when certSent $ do sigAlg <- getLocalSignatureAlg mhashSig <- case usedVersion of TLS12 -> do Just (_, Just hashSigs, _) <- usingHState ctx getClientCertRequest -- The values in the "signature_algorithms" extension -- are in descending order of preference. -- However here the algorithms are selected according -- to client preference in 'supportedHashSignatures'. let suppHashSigs = supportedHashSignatures $ ctxSupported ctx matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs hashSigs' = filter (`elem` hashSigs) matchHashSigs when (null hashSigs') $ throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm 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 <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs sendPacket ctx $ Handshake [CertVerify sigDig] getLocalSignatureAlg = do pk <- usingHState ctx getLocalPrivateKey case pk of PrivKeyRSA _ -> return RSA PrivKeyDSA _ -> return DSS 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) 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) (supportedCiphers $ ctxSupported 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. unless (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 <$> extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts of Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of Just protos -> when (proto `elem` protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return () _ -> 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 RSA (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> do doDHESignature dhparams signature DSS (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> do doECDHESignature ecdhparams signature RSA (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> do doECDHESignature ecdhparams signature ECDSA (cke, SKX_Unparsed bytes) -> do ver <- usingState_ ctx getVersion case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure) Right realSkx -> processWithCipher cipher realSkx -- we need to resolve the result. and recall processWithCipher .. (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) doDHESignature dhparams signature signatureType = do -- FIXME verify if FF group is one of supported groups verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams, True, HandshakeFailure) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature signatureType = do -- FIXME verify if EC group is one of supported groups verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature 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.4.1/Network/TLS/Handshake/Server.hs0000644000000000000000000007755613240574164016322 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Server ( handshakeServer , handshakeServerWith ) 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 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 qualified Data.ByteString as B import Control.Monad.State.Strict 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 -- <- 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 -- rejecting SSL2. RFC 6176 when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion) -- rejecting SSL3. RFC 7568 -- when (clientVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion) -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) && (0x5600 `elem` ciphers) && 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 -- If compression is null, commonCompressions should be [0]. when (null commonCompressions) $ throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) -- SNI (Server Name Indication) let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode False of Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) where toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing _ -> Nothing extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName -- When selecting a cipher we must ensure that it is allowed for the -- TLS version but also that all its key-exchange requirements -- will be met. -- Some ciphers require a signature and a hash. With TLS 1.2 the hash -- algorithm is selected from a combination of server configuration and -- the client "supported_signatures" extension. So we cannot pick -- such a cipher if no hash is available for it. It's best to skip this -- cipher and pick another one (with another key exchange). -- Cipher selection is performed in two steps: first server credentials -- are flagged as not suitable for signature if not compatible with -- negotiated signature parameters. Then ciphers are evalutated from -- the resulting credentials. let possibleGroups = negotiatedGroupsInCommon ctx exts possibleECGroups = possibleGroups `intersect` availableECGroups possibleFFGroups = possibleGroups `intersect` availableFFGroups hasCommonGroupForECDHE = not (null possibleECGroups) hasCommonGroupForFFDHE = not (null possibleFFGroups) hasCustomGroupForFFDHE = isJust (serverDHEParams sparams) canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE hasCommonGroup cipher = case cipherKeyExchange cipher of CipherKeyExchange_DH_Anon -> canFFDHE CipherKeyExchange_DHE_RSA -> canFFDHE CipherKeyExchange_DHE_DSS -> canFFDHE CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE _ -> True -- group not used -- Ciphers are selected according to TLS version, availability of -- (EC)DHE group and credential depending on key exchange. cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) allCreds = extraCreds `mappend` sharedCredentials (ctxShared ctx) (creds, signatureCreds, ciphersFilteredVersion) = case chosenVersion of TLS12 -> let -- Build a list of all hash/signature algorithms in common between -- client and server. possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts -- Check that a candidate signature credential will be compatible with -- client & server hash/signature algorithms. This returns Just Int -- in order to sort credentials according to server hash/signature -- preference. When the certificate has no matching hash/signature in -- 'possibleHashSigAlgs' the result is Nothing, and the credential will -- not be used to sign. This avoids a failure later in 'decideHashSig'. signingRank cred = case credentialDigitalSignatureAlg cred of Just sig -> findIndex (sig `signatureCompatible`) possibleHashSigAlgs Nothing -> Nothing -- Finally compute credential lists and resulting cipher list. -- -- We try to keep certificates supported by the client, but -- fallback to all credentials if this produces no suitable result -- (see RFC 5246 section 7.4.2 and TLS 1.3 section 4.4.2.2). -- The condition is based on resulting (EC)DHE ciphers so that -- filtering credentials does not give advantage to a less secure -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon. cltCreds = filterCredentialsWithHashSignatures exts allCreds sigCltCreds = filterSortCredentials signingRank cltCreds sigAllCreds = filterSortCredentials signingRank allCreds cltCiphers = selectCipher cltCreds sigCltCreds allCiphers = selectCipher allCreds sigAllCreds resultTuple = if cipherListCredentialFallback cltCiphers then (allCreds, sigAllCreds, allCiphers) else (cltCreds, sigCltCreds, cltCiphers) in resultTuple _ -> (allCreds, allCreds, selectCipher allCreds allCreds) -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds CipherKeyExchange_DH_Anon -> return Nothing CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning DSS signatureCreds CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) resumeSessionData <- case clientSession of (Session (Just clientSessionId)) -> let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId in validateSession serverName <$> resume (Session Nothing) -> return Nothing maybe (return ()) (usingState_ ctx . setClientSNI) serverName case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode False of Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos _ -> return () -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed. case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode False of Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs _ -> return () doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts where commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds) commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions usedCompression = head commonCompressions validateSession _ Nothing = Nothing validateSession sni m@(Just sd) -- SessionData parameters are assumed to match the local server configuration -- so we need to compare only to ClientHello inputs. Abbreviated handshake -- uses the same server_name than full handshake so the same -- credentials (and thus ciphers) are available. | clientVersion < sessionVersion sd = Nothing | sessionCipher sd `notElem` ciphers = Nothing | sessionCompression sd `notElem` compressions = Nothing | isJust sni && sessionClientSNI sd /= sni = Nothing | otherwise = m 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 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 ctx ServerRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts applicationProtocol | 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 [] --- -- When the client sends a certificate, check whether -- it is acceptable for the application. -- --- makeServerHello session = do srand <- ServerRandom <$> getStateRNG ctx 32 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 extensionID_SecureRenegotiation vf ] else return [] protoExt <- applicationProtocol sniExt <- do resuming <- usingState_ ctx isSessionResuming if resuming then return [] else do msni <- usingState_ ctx getClientSNI case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty. Just _ -> return [ ExtensionRaw extensionID_ServerName ""] Nothing -> return [] let extensions = secRengExt ++ protoExt ++ sniExt usingState_ ctx (setVersion chosenVersion) usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression return $ ServerHello chosenVersion srand session (cipherID usedCipher) (compressionID usedCompression) extensions handshakeSendServerData = do serverSession <- newSession ctx usingState_ ctx (setSession serverSession False) serverhello <- makeServerHello serverSession -- send ServerHello & Certificate & ServerKeyXchg & CertReq let certMsg = case mcred of Just (srvCerts, _) -> Certificates srvCerts _ -> Certificates $ CertificateChain [] sendPacket ctx $ Handshake [ serverhello, certMsg ] -- send server key exchange if needed skx <- case cipherKeyExchange usedCipher of CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE RSA CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE DSS CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE RSA _ -> 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 possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups (dhparams, priv, pub) <- case possibleFFGroups of [] -> let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams in case findFiniteFieldGroup dhparams of Just g -> generateFFDHE ctx g Nothing -> do (priv, pub) <- generateDHE ctx dhparams return (dhparams, priv, pub) g:_ -> generateFFDHE ctx g let serverParams = serverDHParamsFrom dhparams pub usingHState ctx $ setServerDHParams serverParams usingHState ctx $ setDHPrivate priv return serverParams -- Choosing a hash algorithm to sign (EC)DHE parameters -- in ServerKeyExchange. Hash algorithm is not suggested by -- the chosen cipher suite. So, it should be selected based on -- the "signature_algorithms" extension in a client hello. -- If RSA is also used for key exchange, this function is -- not called. decideHashSig sigAlg = do usedVersion <- usingState_ ctx getVersion case usedVersion of TLS12 -> do let hashSigs = hashAndSignaturesInCommon ctx exts case filter (sigAlg `signatureCompatible`) hashSigs of [] -> error ("no hash signature for " ++ show sigAlg) x:_ -> return $ Just x _ -> return Nothing generateSKX_DHE sigAlg = do serverParams <- setup_DHE mhashSig <- decideHashSig sigAlg signed <- digitallySignDHParams ctx serverParams sigAlg mhashSig case sigAlg of RSA -> return $ SKX_DHE_RSA serverParams signed DSS -> 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 grp = do (srvpri, srvpub) <- generateECDHE ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams usingHState ctx $ setECDHPrivate srvpri return serverParams generateSKX_ECDHE sigAlg = do let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) g:_ -> return g serverParams <- setup_ECDHE grp mhashSig <- decideHashSig sigAlg signed <- digitallySignECDHParams ctx serverParams sigAlg mhashSig case sigAlg of RSA -> 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 -- <- 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)]) = 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 sigAlgExpected <- getRemoteSignatureAlg -- FIXME should check certificate is allowed for signing verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig if verif then do -- When verification succeeds, commit the -- client certificate chain to the context. -- Just certs <- usingHState ctx getClientCertChain usingState_ ctx $ setClientCertificateChain certs return () else do -- Either verification failed because of an -- invalid format (with an error message), or -- the signature is wrong. In either case, -- ask the application if it wants to -- proceed, we will do that. res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) if res then do -- When verification fails, but the -- application callbacks accepts, we -- also commit the client certificate -- chain to the context. 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 getRemoteSignatureAlg = do pk <- usingHState ctx getRemotePublicKey case pk of PubKeyRSA _ -> return RSA PubKeyDSA _ -> return DSS PubKeyEC _ -> return ECDSA _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) expectChangeCipher ChangeCipherSpec = do return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") checkValidClientCertChain 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 () hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] hashAndSignaturesInCommon ctx exts = let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of -- See Section 7.4.1.4.1 of RFC 5246. Nothing -> [(HashSHA1, SignatureECDSA) ,(HashSHA1, SignatureRSA) ,(HashSHA1, SignatureDSS)] Just (SignatureAlgorithms sas) -> sas sHashSigs = supportedHashSignatures $ ctxSupported ctx -- The values in the "signature_algorithms" extension -- are in descending order of preference. -- However here the algorithms are selected according -- to server preference in 'supportedHashSignatures'. in sHashSigs `intersect` cHashSigs negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode False of Just (NegotiatedGroups clientGroups) -> let serverGroups = supportedGroups (ctxSupported ctx) in serverGroups `intersect` clientGroups _ -> [] credentialDigitalSignatureAlg :: Credential -> Maybe DigitalSignatureAlg credentialDigitalSignatureAlg cred = findDigitalSignatureAlg (credentialPublicPrivateKeys cred) filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials filterSortCredentials rankFun (Credentials creds) = let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ] in Credentials [ cred | (Just _, cred) <- orderedPairs ] filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials filterCredentialsWithHashSignatures exts = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of Nothing -> id Just (SignatureAlgorithms sas) -> let filterCredentials p (Credentials l) = Credentials (filter p l) in filterCredentials (credentialMatchesHashSignatures sas) -- returns True if "signature_algorithms" certificate filtering produced no -- ephemeral D-H nor TLS13 cipher (so handshake with lower security) cipherListCredentialFallback :: [Cipher] -> Bool cipherListCredentialFallback xs = all nonDH xs where nonDH x = case cipherKeyExchange x of CipherKeyExchange_DHE_RSA -> False CipherKeyExchange_DHE_DSS -> False CipherKeyExchange_ECDHE_RSA -> False CipherKeyExchange_ECDHE_ECDSA -> False --CipherKeyExchange_TLS13 -> False _ -> True findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of [] -> Nothing v:_ -> Just v -- We filter our allowed ciphers here according to dynamic credential lists. -- Credentials 'creds' come from server parameters but also SNI callback. -- When the key exchange requires a signature, we use a -- subset of this list named 'sigCreds'. This list has been filtered in order -- to remove certificates that are not compatible with hash/signature -- restrictions (TLS 1.2). getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher] getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams) where authorizedCKE cipher = case cipherKeyExchange cipher of CipherKeyExchange_RSA -> canEncryptRSA CipherKeyExchange_DH_Anon -> True CipherKeyExchange_DHE_RSA -> canSignRSA CipherKeyExchange_DHE_DSS -> canSignDSS CipherKeyExchange_ECDHE_RSA -> canSignRSA -- unimplemented: EC CipherKeyExchange_ECDHE_ECDSA -> False -- unimplemented: non ephemeral DH & ECDH. -- Note, these *should not* be implemented, and have -- (for example) been removed in OpenSSL 1.1.0 -- CipherKeyExchange_DH_DSS -> False CipherKeyExchange_DH_RSA -> False CipherKeyExchange_ECDH_ECDSA -> False CipherKeyExchange_ECDH_RSA -> False canSignDSS = DSS `elem` signingAlgs canSignRSA = RSA `elem` signingAlgs canEncryptRSA = isJust $ credentialsFindForDecrypting creds signingAlgs = credentialsListSigningAlgorithms sigCreds tls-1.4.1/Network/TLS/Handshake/Process.hs0000644000000000000000000001403213215475646016455 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.Strict (gets) 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 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 <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams unless (dhValid params $ dhUnwrapPublic clientDHValue) $ throwCore $ Error_Protocol ("invalid client public key", True, HandshakeFailure) dhpriv <- usingHState ctx getDHPrivate let premaster = dhGetShared params dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams case decodeGroupPublic grp bytes of Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, HandshakeFailure) Right clipub -> do srvpri <- usingHState ctx getECDHPrivate case groupGetShared clipub srvpri of Just premaster -> do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext usingHState ctx $ setMasterSecretFromPre rver role premaster Nothing -> throwCore $ Error_Protocol ("cannote generate a shared secret on ECDH", True, HandshakeFailure) 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 () -- initialize a new Handshake context (initial handshake or renegotiations) startHandshake :: Context -> Version -> ClientRandom -> IO () startHandshake ctx ver crand = let hs = Just $ newEmptyHandshake ver crand in liftIO $ void $ swapMVar (ctxHandshake ctx) hs tls-1.4.1/Network/TLS/Handshake/Signature.hs0000644000000000000000000002450413240574164016776 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Signature -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Signature ( createCertificateVerify , checkCertificateVerify , digitallySignDHParams , digitallySignECDHParams , digitallySignDHParamsVerify , digitallySignECDHParamsVerify , signatureCompatible ) where import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Packet (generateCertificateVerify_SSL, generateCertificateVerify_SSL_DSS, encodeSignedDHParams, encodeSignedECDHParams) import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Key import Network.TLS.Util import Control.Monad.State.Strict signatureCompatible :: DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Bool signatureCompatible RSA (_, SignatureRSA) = True signatureCompatible RSA (_, SignatureRSApssSHA256) = True signatureCompatible RSA (_, SignatureRSApssSHA384) = True signatureCompatible RSA (_, SignatureRSApssSHA512) = True signatureCompatible DSS (_, SignatureDSS) = True signatureCompatible ECDSA (_, SignatureECDSA) = True signatureCompatible _ (_, _) = False checkCertificateVerify :: Context -> Version -> DigitalSignatureAlg -> ByteString -> DigitallySigned -> IO Bool checkCertificateVerify ctx usedVersion sigAlgExpected msgs digSig@(DigitallySigned hashSigAlg _) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> return False (TLS12, Just hs) | sigAlgExpected `signatureCompatible` hs -> doVerify | otherwise -> return False (_, Nothing) -> doVerify (_, Just _) -> return False where doVerify = prepareCertificateVerifySignatureData ctx usedVersion sigAlgExpected hashSigAlg msgs >>= signatureVerifyWithCertVerifyData ctx digSig createCertificateVerify :: Context -> Version -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> ByteString -> IO DigitallySigned createCertificateVerify ctx usedVersion sigAlg hashSigAlg msgs = prepareCertificateVerifySignatureData ctx usedVersion sigAlg hashSigAlg msgs >>= signatureCreateWithCertVerifyData ctx hashSigAlg type CertVerifyData = (SignatureParams, ByteString) -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as -- the SHA1_MD5 algorithm expect an already digested data buildVerifyData :: SignatureParams -> ByteString -> CertVerifyData buildVerifyData (RSAParams SHA1_MD5 enc) bs = (RSAParams SHA1_MD5 enc, hashFinal $ hashUpdate (hashInit SHA1_MD5) bs) buildVerifyData sigParam bs = (sigParam, bs) prepareCertificateVerifySignatureData :: Context -> Version -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> ByteString -> IO CertVerifyData prepareCertificateVerifySignatureData ctx usedVersion sigAlg hashSigAlg msgs | usedVersion == SSL3 = do (hashCtx, params, generateCV_SSL) <- case sigAlg of RSA -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL) DSS -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS) _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg) Just masterSecret <- usingHState ctx $ gets hstMasterSecret return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs) | usedVersion == TLS10 || usedVersion == TLS11 = return $ buildVerifyData (signatureParams sigAlg Nothing) msgs | otherwise = return (signatureParams sigAlg hashSigAlg, msgs) signatureParams :: DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> SignatureParams signatureParams RSA hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 Just (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 Just (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 Just (HashSHA1 , SignatureRSA) -> RSAParams SHA1 RSApkcs1 Just (HashIntrinsic , SignatureRSApssSHA512) -> RSAParams SHA512 RSApss Just (HashIntrinsic , SignatureRSApssSHA384) -> RSAParams SHA384 RSApss Just (HashIntrinsic , SignatureRSApssSHA256) -> RSAParams SHA256 RSApss Nothing -> RSAParams SHA1_MD5 RSApkcs1 Just (hsh , SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) signatureParams DSS hashSigAlg = case hashSigAlg of Nothing -> DSSParams Just (HashSHA1, SignatureDSS) -> DSSParams Just (_ , SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed" Just (_ , sigAlg) -> error ("signature algorithm is incompatible with DSS: " ++ show sigAlg) signatureParams ECDSA hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 Just (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 Just (HashSHA1 , SignatureECDSA) -> ECDSAParams SHA1 Nothing -> ECDSAParams SHA1 Just (hsh , SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) Just (_ , sigAlg) -> error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) signatureParams sig _ = error ("unimplemented signature type: " ++ show sig) signatureCreateWithCertVerifyData :: Context -> Maybe HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do cc <- usingState_ ctx isClientContext DigitallySigned malg <$> signPrivate ctx cc sigParam toSign signatureVerify :: Context -> DigitallySigned -> DigitalSignatureAlg -> ByteString -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) sigAlgExpected toVerifyData = do usedVersion <- usingState_ ctx getVersion let (sigParam, toVerify) = case (usedVersion, hashSigAlg) of (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" (TLS12, Just hs) | sigAlgExpected `signatureCompatible` hs -> (signatureParams sigAlgExpected hashSigAlg, toVerifyData) | otherwise -> error "expecting different signature algorithm" (_, Nothing) -> buildVerifyData (signatureParams sigAlgExpected Nothing) toVerifyData (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) signatureVerifyWithCertVerifyData :: Context -> DigitallySigned -> CertVerifyData -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned _ bs) (sigParam, toVerify) = do cc <- usingState_ ctx isClientContext verifyPublic ctx cc sigParam toVerify bs digitallySignParams :: Context -> ByteString -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned digitallySignParams ctx signatureData sigAlg hashSigAlg = let sigParam = signatureParams sigAlg hashSigAlg in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData) digitallySignDHParams :: Context -> ServerDHParams -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned digitallySignDHParams ctx serverParams sigAlg mhash = do dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams digitallySignParams ctx dhParamsData sigAlg mhash digitallySignECDHParams :: Context -> ServerECDHParams -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -- TLS12 only -> IO DigitallySigned digitallySignECDHParams ctx serverParams sigAlg mhash = do ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams digitallySignParams ctx ecdhParamsData sigAlg mhash digitallySignDHParamsVerify :: Context -> ServerDHParams -> DigitalSignatureAlg -> DigitallySigned -> IO Bool digitallySignDHParamsVerify ctx dhparams sigAlg signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedDHParams dhparams signatureVerify ctx signature sigAlg expectedData digitallySignECDHParamsVerify :: Context -> ServerECDHParams -> DigitalSignatureAlg -> 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.4.1/Network/TLS/Handshake/State.hs0000644000000000000000000003121513240574164016112 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 , getServerDHParams , setServerECDHParams , getServerECDHParams , setDHPrivate , getDHPrivate , setECDHPrivate , getECDHPrivate -- * 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 Network.TLS.Imports import Control.Monad.State.Strict 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 ByteString) , hstKeyState :: !HandshakeKeyState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams) , hstECDHPrivate :: !(Maybe GroupPrivate) , hstHandshakeDigest :: !(Either [ByteString] HashCtx) , hstHandshakeMessages :: [ByteString] , 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) getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust "server DH params" <$> gets hstServerDHParams getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust "server ECDH params" <$> gets hstServerECDHParams setServerDHParams :: ServerDHParams -> HandshakeM () setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) setServerECDHParams :: ServerECDHParams -> HandshakeM () setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp }) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate getECDHPrivate :: HandshakeM GroupPrivate getECDHPrivate = fromJust "server ECDH private" <$> gets hstECDHPrivate setDHPrivate :: DHPrivate -> HandshakeM () setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp }) setECDHPrivate :: GroupPrivate -> HandshakeM () setECDHPrivate shp = modify (\hst -> hst { hstECDHPrivate = 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 :: ByteString -> HandshakeM () addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) updateHandshakeDigest :: ByteString -> 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 ByteString getHandshakeDigest ver role = gets gen where gen hst = case hstHandshakeDigest hst of Right hashCtx -> let msecret = fromJust "master secret" $ hstMasterSecret hst cipher = fromJust "cipher" $ hstPendingCipher hst in generateFinish ver cipher 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 (fromJust "cipher" $ hstPendingCipher hst) 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 -> ByteString -> HandshakeM () setMasterSecret ver role masterSecret = modify $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role in hst { hstMasterSecret = Just masterSecret , hstPendingTxState = Just pendingTx , hstPendingRxState = Just pendingRx } computeKeyBlock :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust "cipher" $ hstPendingCipher hst keyblockSize = cipherKeyBlockSize cipher bulk = cipherBulk cipher digestSize = if hasMAC (bulkF bulk) then hashDigestSize (cipherHash cipher) else 0 keySize = bulkKeySize bulk ivSize = bulkIVSize bulk kb = generateKeyBlock ver cipher (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) masterSecret keyblockSize (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey , cstIV = cWriteIV , cstMacSecret = cMACSecret } cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey , cstIV = sWriteIV , cstMacSecret = sMACSecret } msClient = MacState { msSequence = 0 } msServer = MacState { msSequence = 0 } pendingTx = RecordState { stCryptState = if cc == ClientRole then cstClient else cstServer , stMacState = if cc == ClientRole then msClient else msServer , stCipher = Just cipher , stCompression = hstPendingCompression hst } pendingRx = RecordState { stCryptState = if cc == ClientRole then cstServer else cstClient , stMacState = if cc == ClientRole then msServer else msClient , stCipher = Just cipher , stCompression = hstPendingCompression hst } orOnServer f g = if cc == ClientRole then f else g setServerHelloParameters :: Version -- ^ chosen version -> ServerRandom -> Cipher -> Compression -> HandshakeM () setServerHelloParameters ver sran cipher compression = do modify $ \hst -> hst { hstServerRandom = Just sran , hstPendingCipher = Just cipher , hstPendingCompression = compression , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst } where hashAlg = getHash ver cipher updateDigest (Left bytes) = Right $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes updateDigest (Right _) = error "cannot initialize digest with another digest" -- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getHash :: Version -> Cipher -> Hash getHash ver ciph | ver < TLS12 = SHA1_MD5 | maybe True (< TLS12) (cipherMinVer ciph) = SHA256 | otherwise = cipherHash ciph tls-1.4.1/Network/TLS/Hooks.hs0000644000000000000000000000313313240574164014225 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 = return , hookRecvCertificates = return . const () , hookLogging = def } instance Default Hooks where def = defaultHooks tls-1.4.1/Network/TLS/IO.hs0000644000000000000000000001255013240574164013454 0ustar0000000000000000{-# 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 Network.TLS.Imports import qualified Data.ByteString as B import Data.IORef import Control.Monad.State.Strict import Control.Exception (throwIO) import System.IO.Error (mkIOError, eofErrorType) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx unless established $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing readExact :: Context -> Int -> IO (Either TLSError ByteString) readExact ctx sz = do hdrbs <- contextRecv ctx sz if B.length hdrbs == sz then return $ Right hdrbs else do setEOF ctx return . Left $ if B.null hdrbs then Error_EOF else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) -- | 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 = readExact ctx 2 >>= either (return . Left) sslv2Header #endif | otherwise = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) where recvLengthE = either (return . Left) recvLength recvLength header@(Header _ _ readlen) | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded | otherwise = readExact ctx (fromIntegral readlen) >>= either (return . Left) (getRecord header) #ifdef SSLV2_COMPATIBLE sslv2Header header = if B.head header >= 0x80 then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header else readExact ctx 3 >>= either (return . Left) (recvLengthE . decodeHeader . B.append header) recvDeprecatedLength readlen | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do res <- readExact ctx (fromIntegral readlen) case res of Left e -> return $ Left e Right content -> either (return . Left) (flip getRecord content) $ decodeDeprecatedHeader readlen content #endif maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) getRecord :: Header -> ByteString -> IO (Either TLSError (Record Plaintext)) getRecord header content = do 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 -> Right . Handshake <$> mapM (hookRecvHandshake hooks) hss _ -> return pktRecv case pkt of Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p _ -> return () when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx return pkt -- | 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.4.1/Network/TLS/Imports.hs0000644000000000000000000000266613246063515014610 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-dodgy-exports #-} -- Char8 -- | -- Module : Network.TLS.Imports -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Imports ( -- generic exports ByteString , module Data.ByteString.Char8 -- instance , module Control.Applicative , module Control.Monad , module Data.Bits , module Data.List , module Data.Maybe #if MIN_VERSION_base(4,9,0) , module Data.Semigroup #else , module Data.Monoid #endif , module Data.Ord , module Data.Word #if !MIN_VERSION_base(4,8,0) , sortOn #endif -- project definition , showBytesHex ) where import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Control.Applicative import Control.Monad import Data.Bits import Data.List import Data.Maybe hiding (fromJust) #if MIN_VERSION_base(4,9,0) import Data.Semigroup #else import Data.Monoid #endif import Data.Ord import Data.Word import Data.ByteArray.Encoding as B import qualified Prelude as P #if !MIN_VERSION_base(4,8,0) import Prelude ((.)) sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f = map P.snd . sortBy (comparing P.fst) . map (\x -> let y = f x in y `P.seq` (y, x)) #endif showBytesHex :: ByteString -> P.String showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString) tls-1.4.1/Network/TLS/MAC.hs0000644000000000000000000000513713215475646013557 0ustar0000000000000000-- | -- Module : Network.TLS.MAC -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.MAC ( macSSL , hmac , prf_MD5 , prf_SHA1 , prf_SHA256 , prf_TLS , prf_MD5SHA1 ) where import Network.TLS.Crypto import Network.TLS.Types import Network.TLS.Imports import qualified Data.ByteString as B type HMAC = ByteString -> ByteString -> ByteString macSSL :: Hash -> HMAC macSSL alg secret msg = f $! B.concat [ secret , B.replicate padLen 0x5c , f $! B.concat [ secret, B.replicate padLen 0x36, msg ] ] where padLen = case alg of MD5 -> 48 SHA1 -> 40 _ -> error ("internal error: macSSL called with " ++ show alg) f = hash alg hmac :: Hash -> HMAC hmac alg secret msg = f $! B.append opad (f $! B.append ipad msg) where opad = B.map (xor 0x5c) k' ipad = B.map (xor 0x36) k' f = hash alg bl = hashBlockSize alg k' = B.append kt pad where kt = if B.length secret > fromIntegral bl then f secret else secret pad = B.replicate (fromIntegral bl - B.length kt) 0 hmacIter :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] hmacIter f secret seed aprev len = let an = f secret aprev in let out = f secret (B.concat [an, seed]) in let digestsize = 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 -- | For now we ignore the version, but perhaps some day the PRF will depend -- not only on the cipher PRF algorithm, but also on the protocol version. prf_TLS :: Version -> Hash -> ByteString -> ByteString -> Int -> ByteString prf_TLS _ halg secret seed len = B.concat $ hmacIter (hmac halg) secret seed seed len tls-1.4.1/Network/TLS/Measurement.hs0000644000000000000000000000271113215475646015437 0ustar0000000000000000-- | -- Module : Network.TLS.Measurement -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Measurement ( Measurement(..) , newMeasurement , addBytesReceived , addBytesSent , resetBytesCounters , incrementNbHandshakes ) where import Network.TLS.Imports -- | record some data about this connection. data Measurement = Measurement { nbHandshakes :: !Word32 -- ^ number of handshakes on this context , bytesReceived :: !Word32 -- ^ bytes received since last handshake , bytesSent :: !Word32 -- ^ bytes sent since last handshake } deriving (Show,Eq) newMeasurement :: Measurement newMeasurement = Measurement { nbHandshakes = 0 , bytesReceived = 0 , bytesSent = 0 } addBytesReceived :: Int -> Measurement -> Measurement addBytesReceived sz measure = measure { bytesReceived = bytesReceived measure + fromIntegral sz } addBytesSent :: Int -> Measurement -> Measurement addBytesSent sz measure = measure { bytesSent = bytesSent measure + fromIntegral sz } resetBytesCounters :: Measurement -> Measurement resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 } incrementNbHandshakes :: Measurement -> Measurement incrementNbHandshakes measure = measure { nbHandshakes = nbHandshakes measure + 1 } tls-1.4.1/Network/TLS/Packet.hs0000644000000000000000000006474313240574164014367 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 , generateCertificateVerify_SSL_DSS -- * for extensions parsing , getSignatureHashAlgorithm , putSignatureHashAlgorithm ) where import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap 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(..), Cipher(..)) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as B (convert) data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type } deriving (Show,Eq) {- marshall helpers -} getVersion :: Get Version getVersion = do major <- getWord8 minor <- getWord8 case verOfNum (major, minor) of Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) Just v -> return v 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, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType content <- getOpaque24 return (ty, content) decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello HandshakeType_ServerHello -> decodeServerHello HandshakeType_Certificate -> decodeCertificates HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp HandshakeType_CertRequest -> decodeCertRequest cp HandshakeType_ServerHelloDone -> decodeServerHelloDone HandshakeType_CertVerify -> decodeCertVerify cp HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp HandshakeType_Finished -> decodeFinished decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where getDeprecated = do 1 <- getWord8 ver <- getVersion cipherSpecLen <- fromEnum <$> getWord16 sessionIdLen <- fromEnum <$> getWord16 challengeLen <- fromEnum <$> getWord16 ciphers <- getCipherSpec cipherSpecLen session <- getSessionId sessionIdLen random <- getChallenge challengeLen let compressions = [0] return $ ClientHello ver random session ciphers compressions [] (Just b) getCipherSpec len | len < 3 = return [] getCipherSpec len = do [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) getSessionId 0 = return $ Session Nothing getSessionId len = Session . Just <$> getBytes len getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest decodeClientHello :: Get Handshake decodeClientHello = do ver <- getVersion random <- getClientRandom32 session <- getSession ciphers <- getWords16 compressions <- getWords8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake decodeServerHello = do ver <- getVersion random <- getServerRandom32 session <- getSession cipherid <- getWord16 compressionid <- getWord8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone decodeCertificates :: Get Handshake decodeCertificates = do certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) Right cc -> return $ Certificates cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) decodeFinished :: Get Handshake decodeFinished = Finished <$> (remaining >>= getBytes) decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do mcertTypes <- map (valToType . fromIntegral) <$> getWords8 certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes sigHashAlgs <- if cParamsVersion cp >= TLS12 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) else return Nothing 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 = CKX_ECDH <$> getOpaque8 decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = getServerDHParams -- We don't support ECDH_Anon at this moment -- decodeServerKeyXchg_ECDH :: Get ServerECDHParams decodeServerKeyXchg_RSA :: Get ServerRSAParams decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus <*> getInteger16 -- exponent decodeServerKeyXchgAlgorithmData :: Version -> CipherKeyExchangeType -> Get ServerKeyXchgAlgorithmData decodeServerKeyXchgAlgorithmData ver cke = toCKE where toCKE = case cke of CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH CipherKeyExchange_DHE_RSA -> do dhparams <- getServerDHParams signature <- getDigitallySigned ver return $ SKX_DHE_RSA dhparams signature CipherKeyExchange_DHE_DSS -> do dhparams <- getServerDHParams signature <- getDigitallySigned ver return $ SKX_DHE_DSS dhparams signature CipherKeyExchange_ECDHE_RSA -> do ecdhparams <- getServerECDHParams signature <- getDigitallySigned ver return $ SKX_ECDHE_RSA ecdhparams signature CipherKeyExchange_ECDHE_ECDSA -> do ecdhparams <- getServerECDHParams signature <- getDigitallySigned ver return $ SKX_ECDHE_ECDSA ecdhparams signature _ -> do bs <- remaining >>= getBytes return $ SKX_Unknown bs decodeServerKeyXchg :: CurrentParams -> Get Handshake decodeServerKeyXchg cp = case cParamsKeyXchgType cp of Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = runPut $ encodeHandshakeContent o in let len = 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 bytes -> putOpaque8 bytes encodeHandshakeContent (ServerKeyXchg skg) = case skg of SKX_RSA _ -> error "encodeHandshakeContent SKX_RSA not implemented" SKX_DH_Anon params -> putServerDHParams params SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_Unparsed bytes -> putBytes bytes _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) encodeHandshakeContent HelloRequest = return () encodeHandshakeContent ServerHelloDone = return () encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do putWords8 (map valOfType certTypes) case sigAlgs of Nothing -> return () Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l 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 {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString getRandom32 = getBytes 32 getServerRandom32 :: Get ServerRandom getServerRandom32 = ServerRandom <$> getRandom32 getClientRandom32 :: Get ClientRandom getClientRandom32 = ClientRandom <$> getRandom32 putRandom32 :: ByteString -> Put putRandom32 = putBytes putClientRandom32 :: ClientRandom -> Put putClientRandom32 (ClientRandom r) = putRandom32 r putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r getSession :: Get Session getSession = do len8 <- getWord8 case fromIntegral len8 of 0 -> return $ Session Nothing len -> Session . Just <$> getBytes len putSession :: Session -> Put putSession (Session Nothing) = putWord8 0 putSession (Session (Just s)) = putOpaque8 s getExtensions :: Int -> Get [ExtensionRaw] getExtensions 0 = return [] getExtensions len = do extty <- getWord16 extdatalen <- getWord16 extdata <- getBytes $ fromIntegral extdatalen extxs <- getExtensions (len - fromIntegral extdatalen - 4) return $ ExtensionRaw extty extdata : extxs putExtension :: ExtensionRaw -> Put putExtension (ExtensionRaw ty l) = putWord16 ty >> putOpaque16 l putExtensions :: [ExtensionRaw] -> Put putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" return (h,s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put putSignatureHashAlgorithm (h,s) = putWord8 (valOfType h) >> putWord8 (valOfType s) getServerDHParams :: Get ServerDHParams getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum16 putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p,g,y] getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8 case curveType of 3 -> do -- ECParameters ECCurveType: curve name type mgrp <- toEnumSafe16 <$> getWord16 -- ECParameters NamedCurve case mgrp of Nothing -> error "getServerECDHParams: unknown group" Just grp -> do mxy <- getOpaque8 -- ECPoint case decodeGroupPublic grp mxy of Left e -> error $ "getServerECDHParams: " ++ show e Right grppub -> return $ ServerECDHParams grp grppub _ -> error "getServerECDHParams: unknown type for ECDH Params" putServerECDHParams :: ServerECDHParams -> Put putServerECDHParams (ServerECDHParams grp grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve putOpaque8 $ encodeGroupPublic grppub -- ECPoint getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned ver | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm) <*> getOpaque16 | otherwise = DigitallySigned Nothing <$> getOpaque16 putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned mhash sig) = maybe (return ()) putSignatureHashAlgorithm mhash >> putOpaque16 sig {- - decode and encode ALERT -} decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do x <- getWord8 when (x /= 1) (fail "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) -- rsa pre master secret decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString) decodePreMasterSecret = runGetErr "pre-master-secret" $ do liftM2 (,) getVersion (getBytes 46) encodePreMasterSecret :: Version -> ByteString -> ByteString 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 -> ByteString -> Either TLSError ServerKeyXchgAlgorithmData decodeReallyServerKeyXchgAlgorithmData ver cke = runGetErr "server-key-xchg-algorithm-data" (decodeServerKeyXchgAlgorithmData ver cke) {- - generate things for packet content -} type PRF = ByteString -> ByteString -> Int -> ByteString -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getPRF :: Version -> Cipher -> PRF getPRF ver ciph | ver < TLS12 = prf_MD5SHA1 | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = B.concat $ map computeMD5 ["A","BB","CCC"] where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ] computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ] generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) = prf (B.convert premasterSecret) seed 48 where seed = B.concat [ "master secret", c, s ] generateMasterSecret :: ByteArrayAccess preMaster => Version -> Cipher -> preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret SSL2 _ = generateMasterSecret_SSL generateMasterSecret SSL3 _ = generateMasterSecret_SSL generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ] generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] computeMD5 label = hash MD5 $ B.concat [ mastersecret, computeSHA1 label ] computeSHA1 label = hash SHA1 $ B.concat [ label, mastersecret, s, c ] generateKeyBlock :: Version -> Cipher -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString generateKeyBlock SSL2 _ = generateKeyBlock_SSL generateKeyBlock SSL3 _ = generateKeyBlock_SSL generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 where seed = B.concat [ label, hashFinal hashctx ] generateFinished_SSL :: ByteString -> ByteString -> HashCtx -> ByteString generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] where md5hash = hash MD5 $ B.concat [ mastersecret, pad2, md5left ] sha1hash = hash SHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1) $ foldl hashUpdate hashctx [sender,mastersecret] (md5left,sha1left) = B.splitAt 16 lefthash pad2 = B.replicate 48 0x5c pad1 = B.replicate 48 0x36 generateClientFinished :: Version -> Cipher -> ByteString -> HashCtx -> ByteString generateClientFinished ver ciph | ver < TLS10 = generateFinished_SSL "CLNT" | otherwise = generateFinished_TLS (getPRF ver ciph) "client finished" generateServerFinished :: Version -> Cipher -> ByteString -> HashCtx -> ByteString generateServerFinished ver ciph | ver < TLS10 = generateFinished_SSL "SRVR" | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" {- returns *output* after final MD5/SHA1 -} generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL = generateFinished_SSL "" {- returns *input* before final SHA1 -} generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash where toHash = B.concat [ mastersecret, pad2, sha1left ] sha1left = hashFinal $ flip hashUpdate pad1 $ hashUpdate hashctx mastersecret pad2 = B.replicate 40 0x5c pad1 = B.replicate 40 0x36 encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams -- Combination of RFC 5246 and 4492 is ambiguous. -- Let's assume ecdhe_rsa and ecdhe_dss are identical to -- dhe_rsa and dhe_dss. encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedECDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams fromJustM :: Monad m => String -> Maybe a -> m a fromJustM what Nothing = fail ("fromJust " ++ what ++ ": Nothing") fromJustM _ (Just x) = return x tls-1.4.1/Network/TLS/Parameters.hs0000644000000000000000000003732713240574164015261 0ustar0000000000000000-- | -- 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(..) , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) ) where import Network.TLS.Extension import Network.TLS.Struct import qualified Network.TLS.Struct as Struct import Network.TLS.Session import Network.TLS.Cipher import Network.TLS.Measurement import Network.TLS.Compression import Network.TLS.Crypto import Network.TLS.Credentials import Network.TLS.X509 import Network.TLS.RNG (Seed) import Network.TLS.Imports import Data.Default.Class import qualified Data.ByteString as B 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, ByteString) -- | Allow the use of the Server Name Indication TLS extension during handshake, which allow -- the client to specify which host name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). , clientUseServerNameIndication :: Bool -- | try to establish a connection using this session. , clientWantSessionResume :: Maybe (SessionID, SessionData) , clientShared :: Shared , clientHooks :: ClientHooks -- | In this element, you'll need to override the default empty value of -- of 'supportedCiphers' with a suitable cipherlist. , clientSupported :: Supported , clientDebug :: DebugParams } deriving (Show) defaultParamsClient :: HostName -> ByteString -> 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. Setting parameters is -- necessary for FFDHE key exchange when clients are not compatible -- with RFC 7919. -- -- Value can be one of the standardized groups from module -- "Network.TLS.Extra.FFDHE" or custom parameters generated with -- 'Crypto.PubKey.DH.generateParams'. , 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. The default is empty, specify a suitable -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often -- a good choice. , supportedCiphers :: [Cipher] -- | supported compressions methods , supportedCompressions :: [Compression] -- | All supported hash/signature algorithms pair for client -- certificate verification and server signature in (EC)DHE, -- ordered by decreasing priority. -- -- This list is sent to the peer as part of the signature_algorithms -- extension. It is also used to restrict the choice of server -- credential, signature and hash algorithm, but only when the TLS -- version is 1.2 or above. In order to disable SHA-1 one must then -- also disable earlier protocol versions in 'supportedVersions'. , 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 -- | A list of supported elliptic curves and finite-field groups in the -- preferred order. -- The default value is ['X25519','P256','P384','P521']. -- 'X25519' and 'P256' provide 128-bit security which is strong -- enough until 2030. Both curves are fast because their -- backends are written in C. , supportedGroups :: [Group] } deriving (Show,Eq) defaultSupported :: Supported defaultSupported = Supported { supportedVersions = [TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA512, SignatureECDSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA384, SignatureECDSA) , (Struct.HashSHA256, SignatureRSA) , (Struct.HashSHA256, SignatureECDSA) , (Struct.HashSHA1, SignatureRSA) , (Struct.HashSHA1, SignatureDSS) ] , supportedSecureRenegotiation = True , supportedClientInitiatedRenegotiation = False , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True , supportedGroups = [X25519,P256,P384,P521] } 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 } -- | Group usage callback possible return values. data GroupUsage = GroupUsageValid -- ^ usage of group accepted | GroupUsageInsecure -- ^ usage of group provides insufficient security | GroupUsageUnsupported String -- ^ usage of group rejected for other reason (specified as string) | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value deriving (Show,Eq) defaultGroupUsage :: DHParams -> DHPublic -> IO GroupUsage defaultGroupUsage params public | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime" | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator" | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic | otherwise = return GroupUsageValid -- | 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)) -- | Used by the client to validate the server certificate. The default -- implementation calls 'validateDefault' which validates according to the -- default hooks and checks provided by "Data.X509.Validation". This can -- be replaced with a custom validation function using different settings. , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] -- | This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. , onSuggestALPN :: IO (Maybe [B.ByteString]) -- | This action is called to validate DHE parameters when -- the server selected a finite-field group not part of -- the "Supported Groups Registry". -- See RFC 7919 section 3.1 for recommandations. , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage } defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks { onCertificateRequest = \ _ -> return Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage } 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. Return 'True' to accept the certificate -- anyway, or 'False' to fail verification. , 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. -- -- Returned credentials may be ignored if a client does not support -- the signature algorithms used in the certificate chain. , onServerNameIndication :: Maybe HostName -> IO Credentials -- | at each new handshake, we call this hook to see if we allow handshake to happens. , onNewHandshake :: Measurement -> IO Bool -- | Allow the server to choose an application layer protocol -- suggested from the client through the ALPN -- (Application Layer Protocol Negotiation) extensions. , 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 , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks tls-1.4.1/Network/TLS/Record.hs0000644000000000000000000000216313100036227014346 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.4.1/Network/TLS/Record/Types.hs0000644000000000000000000000652613215475646015504 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.Imports import Network.TLS.Record.State import qualified Data.ByteString as B -- | Represent a TLS record. data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) newtype Fragment a = Fragment { fragmentGetBytes :: ByteString } deriving (Show,Eq) data Plaintext data Compressed data Ciphertext fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag fragmentMap :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b -- | turn a plaintext record into a compressed record using the compression function supplied fragmentCompress :: (ByteString -> RecordM ByteString) -> Fragment Plaintext -> RecordM (Fragment Compressed) fragmentCompress f = fragmentMap f -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (ByteString -> RecordM ByteString) -> Fragment Compressed -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext -> RecordM (Fragment Compressed) fragmentUncipher f = fragmentMap f -- | turn a compressed fragment into a plaintext fragment using the decompression function supplied fragmentUncompress :: (ByteString -> RecordM ByteString) -> Fragment Compressed -> RecordM (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, ByteString) recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes) -- | turn a header and a fragment into a record rawToRecord :: Header -> Fragment a -> Record a rawToRecord (Header pt ver _) fragment = Record pt ver fragment -- | turn a record into a header recordToHeader :: Record a -> Header recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes) tls-1.4.1/Network/TLS/Record/Engage.hs0000644000000000000000000000760613215475646015566 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.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Cap import Network.TLS.Record.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.Imports 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.4.1/Network/TLS/Record/Disengage.hs0000644000000000000000000001437513240574164016260 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.Strict import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Struct import Network.TLS.ErrT import Network.TLS.Cap import Network.TLS.Record.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Crypto import Network.TLS.Compression import Network.TLS.Util import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) 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 (cver < TLS10 || 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 -> ByteString -> RecordState -> RecordM ByteString decryptData ver record econtent tst = decryptOf (cstKey cst) where cipher = fromJust "cipher" $ stCipher tst bulk = cipherBulk cipher cst = stCryptState tst macSize = hashDigestSize $ cipherHash cipher blockSize = bulkBlockSize bulk econtentLen = B.length econtent explicitIV = hasExplicitBlockIV ver sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") decryptOf :: BulkState -> RecordM ByteString decryptOf (BulkStateBlock decryptF) = do let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize -- check if we have enough bytes to cover the minimum for this cipher when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) sanityCheckError {- update IV -} (iv, econtent') <- if explicitIV then 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.4.1/Network/TLS/Record/State.hs0000644000000000000000000001042213215475646015446 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Record.State -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Record.State ( CryptState(..) , MacState(..) , RecordState(..) , newRecordState , incrRecordState , RecordM , runRecordM , getRecordVersion , setRecordIV , withCompression , computeDigest , makeDigest , getBulk , getMacSequence ) where import Control.Monad.State.Strict import Network.TLS.Compression import Network.TLS.Cipher import Network.TLS.ErrT import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.MAC import Network.TLS.Util import Network.TLS.Imports import qualified Data.ByteString as B data CryptState = CryptState { cstKey :: !BulkState , cstIV :: !ByteString , cstMacSecret :: !ByteString } 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 :: ByteString -> RecordState -> RecordState setRecordIV iv st = st { stCryptState = (stCryptState st) { cstIV = iv } } withCompression :: (Compression -> (Compression, a)) -> RecordM a withCompression f = do st <- get let (nc, a) = f $ stCompression st put $ st { stCompression = nc } return a computeDigest :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest ver tstate hdr content = (digest, incrRecordState tstate) where digest = macF (cstMacSecret cst) msg cst = stCryptState tstate cipher = fromJust "cipher" $ stCipher tstate hashA = cipherHash cipher encodedSeq = encodeWord64 $ msSequence $ stMacState tstate (macF, msg) | ver < TLS10 = (macSSL hashA, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ]) | otherwise = (hmac hashA, B.concat [ encodedSeq, encodeHeader hdr, content ]) makeDigest :: Header -> ByteString -> RecordM ByteString makeDigest hdr content = do ver <- getRecordVersion st <- get let (digest, nstate) = computeDigest ver st hdr content put nstate return digest getBulk :: RecordM Bulk getBulk = cipherBulk . fromJust "cipher" . stCipher <$> get getMacSequence :: RecordM Word64 getMacSequence = msSequence . stMacState <$> get tls-1.4.1/Network/TLS/RNG.hs0000644000000000000000000000113613100036227013555 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.4.1/Network/TLS/State.hs0000644000000000000000000002063213240574164014225 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Network.TLS.State -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the State module contains calls related to state initialization/manipulation -- which is use by the Receiving module and the Sending module. -- module Network.TLS.State ( TLSState(..) , TLSSt , runTLSState , newTLSState , withTLSRNG , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial , certVerifyHandshakeTypeMaterial , certVerifyHandshakeMaterial , setVersion , setVersionIfUnset , getVersion , getVersionWithDefault , setSecureRenegotiation , getSecureRenegotiation , setExtensionALPN , getExtensionALPN , setNegotiatedProtocol , getNegotiatedProtocol , setClientALPNSuggest , getClientALPNSuggest , setClientEcPointFormatSuggest , getClientEcPointFormatSuggest , getClientCertificateChain , setClientCertificateChain , setClientSNI , getClientSNI , getVerifiedData , setSession , getSession , isSessionResuming , isClientContext -- * 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.Strict 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 :: ByteString -- RFC 5746 , stServerVerifiedData :: ByteString -- RFC 5746 , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , 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 , stExtensionALPN = False , stHandshakeRecordCont = Nothing , stNegotiatedProtocol = Nothing , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing , stRandomGen = rng , stVersion = Nothing , stClientContext = clientContext } updateVerifiedData :: Role -> ByteString -> TLSSt () updateVerifiedData sending bs = do cc <- isClientContext if cc /= sending then modify (\st -> st { stServerVerifiedData = bs }) else modify (\st -> st { stClientVerifiedData = bs }) finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello = True finishHandshakeTypeMaterial HandshakeType_ServerHello = True finishHandshakeTypeMaterial HandshakeType_Certificate = True finishHandshakeTypeMaterial HandshakeType_HelloRequest = False finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True finishHandshakeTypeMaterial HandshakeType_CertRequest = True finishHandshakeTypeMaterial HandshakeType_CertVerify = True finishHandshakeTypeMaterial HandshakeType_Finished = True finishHandshakeMaterial :: Handshake -> Bool finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake certVerifyHandshakeTypeMaterial :: HandshakeType -> Bool certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False certVerifyHandshakeTypeMaterial HandshakeType_ServerHelloDone = True certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False certVerifyHandshakeTypeMaterial HandshakeType_Finished = False certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake setSession :: Session -> Bool -> TLSSt () setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming }) getSession :: TLSSt Session getSession = gets stSession isSessionResuming :: TLSSt Bool isSessionResuming = gets stSessionResuming setVersion :: Version -> TLSSt () setVersion ver = modify (\st -> st { stVersion = Just ver }) setVersionIfUnset :: Version -> TLSSt () setVersionIfUnset ver = modify maybeSet where maybeSet st = case stVersion st of Nothing -> st { stVersion = Just ver } Just _ -> st getVersion :: TLSSt Version getVersion = fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion getVersionWithDefault :: Version -> TLSSt Version getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt () setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b }) getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionALPN :: Bool -> TLSSt () setExtensionALPN b = modify (\st -> st { stExtensionALPN = b }) getExtensionALPN :: TLSSt Bool getExtensionALPN = gets stExtensionALPN setNegotiatedProtocol :: B.ByteString -> TLSSt () setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s }) getNegotiatedProtocol :: TLSSt (Maybe B.ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol setClientALPNSuggest :: [B.ByteString] -> TLSSt () setClientALPNSuggest ps = modify (\st -> st { stClientALPNSuggest = Just ps}) getClientALPNSuggest :: TLSSt (Maybe [B.ByteString]) getClientALPNSuggest = gets stClientALPNSuggest setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt () setClientEcPointFormatSuggest epf = modify (\st -> st { stClientEcPointFormatSuggest = Just epf}) getClientEcPointFormatSuggest :: TLSSt (Maybe [EcPointFormat]) getClientEcPointFormatSuggest = gets stClientEcPointFormatSuggest setClientCertificateChain :: CertificateChain -> TLSSt () setClientCertificateChain s = modify (\st -> st { stClientCertificateChain = Just s }) getClientCertificateChain :: TLSSt (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain setClientSNI :: HostName -> TLSSt () setClientSNI hn = modify (\st -> st { stClientSNI = Just hn }) getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI getVerifiedData :: Role -> TLSSt ByteString getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) isClientContext :: TLSSt Role isClientContext = gets stClientContext genRandom :: Int -> TLSSt ByteString genRandom n = do withRNG (getRandomBytes n) withRNG :: MonadPseudoRandom StateRNG a -> TLSSt a withRNG f = do st <- get let (a,rng') = withTLSRNG (stRandomGen st) f put (st { stRandomGen = rng' }) return a tls-1.4.1/Network/TLS/Session.hs0000644000000000000000000000162213100036227014552 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.4.1/Network/TLS/Sending.hs0000644000000000000000000000757413240574164014546 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.Monad.State.Strict import Control.Concurrent.MVar import Data.IORef 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 import Network.TLS.Imports -- | '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.4.1/Network/TLS/Receiving.hs0000644000000000000000000000611313240574164015056 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.Strict 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 import Network.TLS.Imports processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) = case decodeChangeCipherSpec $ fragmentGetBytes fragment of Left err -> return $ Left err Right _ -> do switchRxEncryption ctx return $ Right ChangeCipherSpec processPacket ctx (Record ProtocolType_Handshake ver fragment) = do keyxchg <- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg } -- get back the optional continuation, and parse as many handshake record as possible. mCont <- gets stHandshakeRecordCont modify (\st -> st { stHandshakeRecordCont = Nothing }) hss <- parseMany currentParams mCont (fragmentGetBytes fragment) return $ Handshake hss where parseMany currentParams mCont bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont -> modify (\st -> st { stHandshakeRecordCont = Just cont }) >> return [] GotSuccess (ty,content) -> either throwError (return . (:[])) $ decodeHandshake currentParams ty content GotSuccessRemaining (ty,content) left -> case decodeHandshake currentParams ty content of Left err -> throwError err Right hh -> (hh:) <$> parseMany currentParams Nothing left processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) = case decodeDeprecatedHandshake $ fragmentGetBytes fragment of Left err -> return $ Left err Right hs -> return $ Right $ Handshake [hs] switchRxEncryption :: Context -> IO () switchRxEncryption ctx = usingHState ctx (gets hstPendingRxState) >>= \rx -> liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) tls-1.4.1/Network/TLS/Util.hs0000644000000000000000000000502013215475646014063 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Util ( sub , takelast , partition3 , partition6 , fromJust , and' , (&&!) , bytesEq , fmapEither , catchException ) where import qualified Data.ByteString as B import Network.TLS.Imports import Control.Exception (SomeException) import Control.Concurrent.Async sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len | B.length b < offset + len = Nothing | otherwise = Just $ B.take len $ snd $ B.splitAt offset b takelast :: Int -> ByteString -> Maybe ByteString takelast i b | B.length b >= i = sub b (B.length b - i) i | otherwise = Nothing partition3 :: ByteString -> (Int,Int,Int) -> Maybe (ByteString, ByteString, ByteString) partition3 bytes (d1,d2,d3) | any (< 0) l = Nothing | sum l /= B.length bytes = Nothing | otherwise = Just (p1,p2,p3) where l = [d1,d2,d3] (p1, r1) = B.splitAt d1 bytes (p2, r2) = B.splitAt d2 r1 (p3, _) = B.splitAt d3 r2 partition6 :: ByteString -> (Int,Int,Int,Int,Int,Int) -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString) partition6 bytes (d1,d2,d3,d4,d5,d6) = if B.length bytes < s then Nothing else Just (p1,p2,p3,p4,p5,p6) where s = sum [d1,d2,d3,d4,d5,d6] (p1, r1) = B.splitAt d1 bytes (p2, r2) = B.splitAt d2 r1 (p3, r3) = B.splitAt d3 r2 (p4, r4) = B.splitAt d4 r3 (p5, r5) = B.splitAt d5 r4 (p6, _) = B.splitAt d6 r5 fromJust :: String -> Maybe a -> a fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck fromJust _ (Just x) = x -- | This is a strict version of 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 :: ByteString -> ByteString -> 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 = fmap f catchException :: IO a -> (SomeException -> IO a) -> IO a catchException action handler = withAsync action waitCatch >>= either handler return tls-1.4.1/Network/TLS/Util/ASN1.hs0000644000000000000000000000230313215475646014566 0ustar0000000000000000-- | -- Module : Network.TLS.Util.ASN1 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- ASN1 utils for TLS -- module Network.TLS.Util.ASN1 ( decodeASN1Object , encodeASN1Object ) where import Network.TLS.Imports import Data.ASN1.Types (fromASN1, toASN1, ASN1Object) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..)) -- | Attempt to decode a bytestring representing -- an DER ASN.1 serialized object into the object. decodeASN1Object :: ASN1Object a => String -> ByteString -> Either String a decodeASN1Object name bs = case decodeASN1' DER bs of Left e -> Left (name ++ ": cannot decode ASN1: " ++ show e) Right asn1 -> case fromASN1 asn1 of Left e -> Left (name ++ ": cannot parse ASN1: " ++ show e) Right (d,_) -> Right d -- | Encode an ASN.1 Object to the DER serialized bytestring encodeASN1Object :: ASN1Object a => a -> ByteString encodeASN1Object obj = encodeASN1' DER $ toASN1 obj [] tls-1.4.1/Network/TLS/Util/Serialization.hs0000644000000000000000000000040513100036227016657 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.4.1/Network/TLS/Types.hs0000644000000000000000000000236613215475646014264 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 Network.TLS.Imports type HostName = String -- | 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 , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName , 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.4.1/Network/TLS/Wire.hs0000644000000000000000000001165313240574164014056 0ustar0000000000000000-- | -- Module : Network.TLS.Wire -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- the Wire module is a specialized marshalling/unmarshalling package related to the TLS protocol. -- all multibytes values are written as big endian. -- module Network.TLS.Wire ( Get , GetResult(..) , GetContinuation , runGet , runGetErr , runGetMaybe , tryGet , remaining , getWord8 , getWords8 , getWord16 , getWords16 , getWord24 , getWord32 , getBytes , getOpaque8 , getOpaque16 , getOpaque24 , getInteger16 , getBigNum16 , getList , processBytes , isEmpty , Put , runPut , putWord8 , putWords8 , putWord16 , putWords16 , putWord24 , putWord32 , putBytes , putOpaque8 , putOpaque16 , putOpaque24 , putInteger16 , putBigNum16 , encodeWord16 , encodeWord32 , encodeWord64 ) where import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put import qualified Data.ByteString as B import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a data GetResult a = GotError TLSError | GotPartial (GetContinuation a) | GotSuccess a | GotSuccessRemaining a ByteString runGet :: String -> Get a -> ByteString -> GetResult a runGet lbl f = toGetResult <$> G.runGetPartial (label lbl f) where toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err) toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont) toGetResult (G.Done r bsLeft) | B.null bsLeft = GotSuccess r | otherwise = GotSuccessRemaining r bsLeft runGetErr :: String -> Get a -> ByteString -> Either TLSError a runGetErr lbl getter b = toSimple $ runGet lbl getter b where toSimple (GotError err) = Left err toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet")) toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes")) toSimple (GotSuccess r) = Right r runGetMaybe :: Get a -> ByteString -> Maybe a runGetMaybe f = either (const Nothing) Just . G.runGet f tryGet :: Get a -> ByteString -> Maybe a tryGet f = either (const Nothing) Just . G.runGet f getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8 getWord16 :: Get Word16 getWord16 = getWord16be getWords16 :: Get [Word16] getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16 getWord24 :: Get Int getWord24 = do a <- fromIntegral <$> getWord8 b <- fromIntegral <$> getWord8 c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c getWord32 :: Get Word32 getWord32 = getWord32be getOpaque8 :: Get ByteString getOpaque8 = getWord8 >>= getBytes . fromIntegral getOpaque16 :: Get ByteString getOpaque16 = getWord16 >>= getBytes . fromIntegral getOpaque24 :: Get ByteString getOpaque24 = getWord24 >>= getBytes getInteger16 :: Get Integer getInteger16 = os2ip <$> getOpaque16 getBigNum16 :: Get BigNum getBigNum16 = BigNum <$> getOpaque16 getList :: Int -> Get (Int, a) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen) where getElements len | len < 0 = error "list consumed too much data. should never happen with isolate." | len == 0 = return [] | otherwise = getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f putWords8 :: [Word8] -> Put putWords8 l = do putWord8 $ fromIntegral (length l) mapM_ putWord8 l putWord16 :: Word16 -> Put putWord16 = putWord16be putWord32 :: Word32 -> Put putWord32 = putWord32be putWords16 :: [Word16] -> Put putWords16 l = do putWord16 $ 2 * fromIntegral (length l) mapM_ putWord16 l putWord24 :: Int -> Put putWord24 i = do let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff) mapM_ putWord8 [a,b,c] putBytes :: ByteString -> Put putBytes = putByteString putOpaque8 :: ByteString -> Put putOpaque8 b = putWord8 (fromIntegral $ B.length b) >> putBytes b putOpaque16 :: ByteString -> Put putOpaque16 b = putWord16 (fromIntegral $ B.length b) >> putBytes b putOpaque24 :: ByteString -> Put putOpaque24 b = putWord24 (B.length b) >> putBytes b putInteger16 :: Integer -> Put putInteger16 = putOpaque16 . i2osp putBigNum16 :: BigNum -> Put putBigNum16 (BigNum b) = putOpaque16 b encodeWord16 :: Word16 -> ByteString encodeWord16 = runPut . putWord16 encodeWord32 :: Word32 -> ByteString encodeWord32 = runPut . putWord32 encodeWord64 :: Word64 -> ByteString encodeWord64 = runPut . putWord64be tls-1.4.1/Network/TLS/X509.hs0000644000000000000000000000371313240574164013613 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.4.1/Tests/Tests.hs0000644000000000000000000003427713215475646013277 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} import Test.Tasty import Test.Tasty.QuickCheck import Test.QuickCheck.Monadic import PipeChan import Connection import Marshalling import Ciphers import Data.Maybe import Data.List (intersect) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Network.TLS import Network.TLS.Extra import 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 :: Context -> IO C8.ByteString recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan C8.ByteString -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () 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 () runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO () runTLSPipeSimple params = 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 () runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO () runTLSInitFailure params = do (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient) assertIsLeft cRes assertIsLeft sRes where tlsServer ctx = handshake ctx >> bye ctx >> return ("server success" :: String) tlsClient ctx = handshake ctx >> bye ctx >> return ("client success" :: String) prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do params <- pick arbitraryPairParams runTLSPipeSimple params prop_handshake_ciphersuites :: PropertyM IO () prop_handshake_ciphersuites = do let clientVersions = [TLS12] serverVersions = [TLS12] clientCiphers <- pick arbitraryCiphers serverCiphers <- pick arbitraryCiphers (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) let shouldFail = null (clientCiphers `intersect` serverCiphers) if shouldFail then runTLSInitFailure (clientParam,serverParam) else runTLSPipeSimple (clientParam,serverParam) prop_handshake_hashsignatures :: PropertyM IO () prop_handshake_hashsignatures = do let clientVersions = [TLS12] serverVersions = [TLS12] ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_DHE_RSA_AES128_SHA1 , cipher_DHE_DSS_AES128_SHA1 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (ciphers, ciphers) clientHashSigs <- pick arbitraryHashSignatures serverHashSigs <- pick arbitraryHashSignatures let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = clientHashSigs } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedHashSignatures = serverHashSigs } } shouldFail = null (clientHashSigs `intersect` serverHashSigs) if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam') -- Tests ability to use or ignore client "signature_algorithms" extension when -- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but -- the server RSA certificate has a SHA-1 signature that the client does not -- support. Server may choose the DSA certificate only when cipher -- DHE_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA -- certificate. prop_handshake_cert_fallback :: PropertyM IO () prop_handshake_cert_fallback = do let clientVersions = [TLS12] serverVersions = [TLS12] commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ] otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_DHE_DSS_AES128_SHA1 ] hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ] chainRef <- run $ newIORef Nothing clientCiphers <- pick $ sublistOf otherCiphers serverCiphers <- pick $ sublistOf otherCiphers (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = hashSignatures } , clientHooks = (clientHooks clientParam) { onServerCertificate = \_ _ _ chain -> writeIORef chainRef (Just chain) >> return [] } } dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers runTLSPipeSimple (clientParam',serverParam) serverChain <- run $ readIORef chainRef dssDisallowed `assertEq` isLeafRSA serverChain where isLeafRSA chain = case chain >>= leafPublicKey of Just (PubKeyRSA _) -> True _ -> False prop_handshake_groups :: PropertyM IO () prop_handshake_groups = do let clientVersions = [TLS12] serverVersions = [TLS12] ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_DHE_RSA_AES256GCM_SHA384 , cipher_DHE_RSA_AES128_SHA1 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (ciphers, ciphers) clientGroups <- pick arbitraryGroups serverGroups <- pick arbitraryGroups denyCustom <- pick arbitrary let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = clientGroups } , clientHooks = (clientHooks clientParam) { onCustomFFDHEGroup = \_ _ -> return groupUsage } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups } } isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') shouldFail = null (clientGroups `intersect` serverGroups) && isCustom && denyCustom if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam') prop_handshake_client_auth :: PropertyM IO () prop_handshake_client_auth = do (clientParam,serverParam) <- pick arbitraryPairParams cred <- pick arbitraryClientCredential let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } } serverParam' = serverParam { serverWantClientCert = True , serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } } runTLSPipeSimple (clientParam',serverParam') where validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) prop_handshake_alpn :: PropertyM IO () prop_handshake_alpn = do (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onSuggestALPN = return $ Just ["h2", "http/1.1"] } } serverParam' = serverParam { serverHooks = (serverHooks serverParam) { onALPNClientSuggest = Just alpn } } params' = (clientParam',serverParam') runTLSPipe params' tlsServer tlsClient where tlsServer ctx queue = do handshake ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () alpn xs | "h2" `elem` xs = return "h2" | otherwise = return "http/1.1" prop_handshake_sni :: PropertyM IO () prop_handshake_sni = do (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { clientServerIdentification = (serverName, "") , clientUseServerNameIndication = True } params' = (clientParam',serverParam) runTLSPipe params' tlsServer tlsClient where tlsServer ctx queue = do handshake ctx sni <- getClientSNI ctx Just serverName `assertEq` sni d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () serverName = "haskell.org" prop_handshake_renegotiation :: PropertyM IO () prop_handshake_renegotiation = 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 () 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 runTLSPipeSimple params -- and resume sessionParams <- run $ readIORef sessionRef assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPipeSimple params2 assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) assertIsLeft :: (Show b, Monad m) => Either a b -> m () assertIsLeft (Left _) = return() assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") 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 "Initiation" (monadicIO prop_handshake_initiate) , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) , testProperty "Groups" (monadicIO prop_handshake_groups) , testProperty "Certificate fallback" (monadicIO prop_handshake_cert_fallback) , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) , testProperty "ALPN" (monadicIO prop_handshake_alpn) , testProperty "SNI" (monadicIO prop_handshake_sni) , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) ] tls-1.4.1/Tests/Certificate.hs0000644000000000000000000000671313137673646014414 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Certificate ( arbitraryX509 , arbitraryX509WithKey , simpleCertificate , simpleX509 ) where import Control.Applicative import Test.Tasty.QuickCheck import Data.ASN1.OID import Data.X509 import Data.Hourglass import qualified Data.ByteString as B import PubKey arbitraryDN :: Gen DistinguishedName arbitraryDN = return $ DistinguishedName [] instance Arbitrary Date where arbitrary = do y <- choose (1971, 2035) m <- elements [ January .. December] d <- choose (1, 30) return $ normalizeDate $ Date y m d normalizeDate :: Date -> Date normalizeDate d = timeConvert (timeConvert d :: Elapsed) instance Arbitrary TimeOfDay where arbitrary = do h <- choose (0, 23) mi <- choose (0, 59) se <- choose (0, 59) nsec <- return 0 return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec instance Arbitrary DateTime where arbitrary = DateTime <$> arbitrary <*> arbitrary maxSerial :: Integer maxSerial = 16777216 arbitraryCertificate :: PubKey -> Gen Certificate arbitraryCertificate pubKey = do serial <- choose (0,maxSerial) 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 [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment,KeyUsage_keyCertSign] ] } where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] simpleCertificate :: PubKey -> Certificate simpleCertificate pubKey = Certificate { certVersion = 3 , certSerial = 0 , certSignatureAlg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) , certIssuerDN = simpleDN , certSubjectDN = simpleDN , certValidity = (time1, time2) , certPubKey = pubKey , certExtensions = Extensions $ Just [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment] ] } where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) simpleDN = DistinguishedName [] simpleX509 :: PubKey -> SignedCertificate simpleX509 pubKey = 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, t) -> Gen SignedCertificate 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 :: Gen SignedCertificate arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) tls-1.4.1/Tests/Ciphers.hs0000644000000000000000000000356113240574164013553 0ustar0000000000000000-- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Ciphers ( propertyBulkFunctional ) where import Control.Applicative ((<$>), (<*>)) import Test.Tasty.QuickCheck import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Extra.Cipher arbitraryKey :: Bulk -> Gen B.ByteString arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString deriving (Show,Eq) instance Arbitrary BulkTest where arbitrary = do bulk <- cipherBulk `fmap` elements ciphersuite_all BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk <*> arbitraryText bulk propertyBulkFunctional :: BulkTest -> Bool propertyBulkFunctional (BulkTest bulk key iv t additional) = let enc = bulkInit bulk BulkEncrypt key dec = bulkInit bulk BulkDecrypt key in case (enc, dec) of (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF _ -> True where block e d = let (etxt, e_iv) = e iv t (dtxt, d_iv) = d iv etxt in dtxt == t && d_iv == e_iv stream e d = (fst . d . fst . e) t == t aead e d = let (encrypted, at) = e iv t additional (decrypted, at2) = d iv encrypted additional in decrypted == t && at == at2 tls-1.4.1/Tests/Connection.hs0000644000000000000000000002643513215475646014271 0ustar0000000000000000-- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Connection ( newPairContext , arbitraryCiphers , arbitraryVersions , arbitraryHashSignatures , arbitraryGroups , arbitraryPairParams , arbitraryPairParamsWithVersionsAndCiphers , arbitraryClientCredential , isCustomDHParams , leafPublicKey , oneSessionManager , setPairParamsSessionManager , setPairParamsSessionResuming , establishDataPipe , initiateDataPipe ) where import Test.Tasty.QuickCheck import Certificate import PubKey import PipeChan import Network.TLS as TLS import Network.TLS.Extra import Data.X509 import Data.Default.Class import Data.IORef import Control.Applicative import Control.Concurrent.Chan import Control.Concurrent import qualified Control.Exception as E import Data.List (isInfixOf) import qualified Data.ByteString as B debug :: Bool debug = False knownCiphers :: [Cipher] knownCiphers = filter nonECDSA (ciphersuite_all ++ ciphersuite_weak) where ciphersuite_weak = [ cipher_DHE_DSS_RC4_SHA1 , cipher_RC4_128_MD5 , cipher_null_MD5 , cipher_null_SHA1 ] -- arbitraryCredentialsOfEachType cannot generate ECDSA nonECDSA c = not ("ECDSA" `isInfixOf` cipherName c) arbitraryCiphers :: Gen [Cipher] arbitraryCiphers = listOf1 $ elements knownCiphers knownVersions :: [Version] knownVersions = [SSL3,TLS10,TLS11,TLS12] arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions knownHashSignatures :: [HashAndSignatureAlgorithm] knownHashSignatures = filter nonECDSA availableHashSignatures where availableHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssSHA256) ,(TLS.HashSHA512, SignatureRSA) ,(TLS.HashSHA512, SignatureECDSA) ,(TLS.HashSHA384, SignatureRSA) ,(TLS.HashSHA384, SignatureECDSA) ,(TLS.HashSHA256, SignatureRSA) ,(TLS.HashSHA256, SignatureECDSA) ,(TLS.HashSHA1, SignatureRSA) ,(TLS.HashSHA1, SignatureDSS) ] -- arbitraryCredentialsOfEachType cannot generate ECDSA nonECDSA (_,s) = s /= SignatureECDSA arbitraryHashSignatures :: Gen [HashAndSignatureAlgorithm] arbitraryHashSignatures = sublistOf knownHashSignatures knownGroups, knownECGroups, knownFFGroups :: [Group] knownECGroups = [P256,P384,P521,X25519,X448] knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192] knownGroups = knownECGroups ++ knownFFGroups arbitraryGroups :: Gen [Group] arbitraryGroups = listOf1 $ elements knownGroups arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType = do let (pubKey, privKey) = getGlobalRSAPair (dsaPub, dsaPriv) <- arbitraryDSAPair mapM (\(pub, priv) -> do cert <- arbitraryX509WithKey (pub, priv) return (CertificateChain [cert], priv) ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey) , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) ] isCustomDHParams :: DHParams -> Bool isCustomDHParams params = params == dhParams leafPublicKey :: CertificateChain -> Maybe PubKey leafPublicKey (CertificateChain []) = Nothing leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf) arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` (\cs -> or [maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) clientCiphers <- arbitraryCiphers `suchThat` (\cs -> or [x `elem` serverCiphers && maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) return (clientCiphers, serverCiphers) arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = do connectVersion <- elements knownVersions (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion -- The shared ciphers may set a floor on the compatible protocol versions let allowedVersions = [ v | v <- knownVersions, or [ x `elem` serverCiphers && maybe True (<= v) (cipherMinVer x) | x <- clientCiphers ]] serAllowedVersions <- (:[]) `fmap` elements allowedVersions arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) arbitraryECGroupPair :: Gen ([Group], [Group]) arbitraryECGroupPair = do let arbitraryECGroups = listOf1 $ elements knownECGroups serverGroups <- arbitraryECGroups clientGroups <- arbitraryECGroups `suchThat` any (`elem` serverGroups) return (clientGroups, serverGroups) arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) arbitraryHashSignaturePair = do serverHashSignatures <- shuffle knownHashSignatures clientHashSignatures <- shuffle knownHashSignatures return (clientHashSignatures, serverHashSignatures) arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version]) -> ([Cipher], [Cipher]) -> Gen (ClientParams, ServerParams) arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do secNeg <- arbitrary dhparams <- elements [dhParams,ffdhe2048,ffdhe3072] creds <- arbitraryCredentialsOfEachType (clientGroups, serverGroups) <- arbitraryECGroupPair (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def { serverSupported = def { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures } , serverDHEParams = Just dhparams , serverShared = def { sharedCredentials = Credentials creds } } let clientState = (defaultParamsClient "" B.empty) { clientSupported = def { supportedCiphers = clientCiphers , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg , supportedGroups = clientGroups , supportedHashSignatures = clientHashSignatures } , clientShared = def { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () , cacheQuery = \_ _ _ -> return ValidationCachePass } } } return (clientState, serverState) arbitraryClientCredential :: Gen Credential arbitraryClientCredential = arbitraryCredentialsOfEachType >>= elements -- | 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 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 :: (SessionID, SessionData) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionResuming sessionStuff (clientState, serverState) = ( clientState { clientWantSessionResume = Just sessionStuff } , serverState) newPairContext :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) newPairContext pipe (cParams, sParams) = do let noFlush = return () let noClose = return () let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe) let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe) cCtx' <- contextNew cBackend cParams sCtx' <- contextNew sBackend sParams contextHookSetLogging cCtx' (logging "client: ") contextHookSetLogging sCtx' (logging "server: ") return (cCtx', sCtx') where logging pre = if debug then def { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } else def establishDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> IO (Chan start, Chan result) 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" (serverSupported $ snd params)) _ <- forkIO $ E.catch (tlsClient startQueue cCtx) (printAndRaise "client" (clientSupported $ fst params)) return (startQueue, resultQueue) where printAndRaise :: String -> Supported -> E.SomeException -> IO () printAndRaise s supported e = do putStrLn $ s ++ " exception: " ++ show e ++ ", supported: " ++ show supported E.throw e initiateDataPipe :: (ClientParams, ServerParams) -> (Context -> IO a1) -> (Context -> IO a) -> IO (Either E.SomeException a, Either E.SomeException a1) initiateDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe _ <- (runPipe pipe) cQueue <- newChan sQueue <- newChan (cCtx, sCtx) <- newPairContext pipe params _ <- forkIO $ E.catch (tlsServer sCtx >>= writeSuccess sQueue) (writeException sQueue) _ <- forkIO $ E.catch (tlsClient cCtx >>= writeSuccess cQueue) (writeException cQueue) sRes <- readChan sQueue cRes <- readChan cQueue return (cRes, sRes) where writeException :: Chan (Either E.SomeException a) -> E.SomeException -> IO () writeException queue e = writeChan queue (Left e) writeSuccess :: Chan (Either E.SomeException a) -> a -> IO () writeSuccess queue res = writeChan queue (Right res) tls-1.4.1/Tests/Marshalling.hs0000644000000000000000000000700513137673636014425 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} 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 } tls-1.4.1/Tests/PipeChan.hs0000644000000000000000000000440613137673636013655 0ustar0000000000000000-- create a similar concept than a unix pipe. module PipeChan ( PipeChan(..) , newPipe , runPipe , readPipeA , readPipeB , writePipeA , writePipeB ) where import Control.Applicative import Control.Concurrent.Chan import Control.Concurrent import Control.Monad (forever) import Data.ByteString (ByteString) import Data.IORef import qualified Data.ByteString as B -- | represent a unidirectional pipe with a buffered read channel and a write channel data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) newUniPipeChan :: IO UniPipeChan newUniPipeChan = UniPipeChan <$> newChan <*> newChan runUniPipe :: UniPipeChan -> IO ThreadId runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w getReadUniPipe :: UniPipeChan -> Chan ByteString getReadUniPipe (UniPipeChan r _) = r getWriteUniPipe :: UniPipeChan -> Chan ByteString getWriteUniPipe (UniPipeChan _ w) = w -- | Represent a bidirectional pipe with 2 nodes A and B data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan newPipe :: IO PipeChan newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan runPipe :: PipeChan -> IO ThreadId runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC readPipeA :: PipeChan -> Int -> IO ByteString readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz writePipeA :: PipeChan -> ByteString -> IO () writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c readPipeB :: PipeChan -> Int -> IO ByteString readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz writePipeB :: PipeChan -> ByteString -> IO () writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s -- helper to read buffered data. readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString readBuffered buf chan sz = do left <- readIORef buf if B.length left >= sz then do let (ret, nleft) = B.splitAt sz left writeIORef buf nleft return ret else do let newSize = (sz - B.length left) newData <- readChan chan writeIORef buf newData remain <- readBuffered buf chan newSize return (left `B.append` remain) tls-1.4.1/Tests/PubKey.hs0000644000000000000000000000654213100036227013343 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.4.1/Benchmarks/Benchmarks.hs0000644000000000000000000001102113137673636015205 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 Data.IORef import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L blockCipher :: Cipher blockCipher = Cipher { cipherID = 0xff12 , cipherName = "rsa-id-const" , cipherBulk = Bulk { bulkName = "id" , bulkKeySize = 16 , bulkIVSize = 16 , bulkExplicitIV= 0 , bulkAuthTagLen= 0 , bulkBlockSize = 16 , bulkF = BulkBlockF $ \_ _ _ -> (\m -> (m, B.empty)) } , cipherHash = MD5 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } recvDataNonNull :: Context -> IO B.ByteString recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l getParams :: Version -> Cipher -> (ClientParams, ServerParams) getParams connectVer cipher = (cParams, sParams) where sParams = def { serverSupported = supported , serverShared = def { sharedCredentials = Credentials [ (CertificateChain [simpleX509 $ PubKeyRSA pubKey], PrivKeyRSA privKey) ] } } cParams = (defaultParamsClient "" B.empty) { clientSupported = supported , clientShared = def { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () , cacheQuery = \_ _ _ -> return ValidationCachePass } } } supported = def { supportedCiphers = [cipher] , supportedVersions = [connectVer] } (pubKey, privKey) = getGlobalRSAPair runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan b -> IO ()) -> (Chan a -> Context -> IO ()) -> a -> IO b runTLSPipe params tlsServer tlsClient d = do (startQueue, resultQueue) <- establishDataPipe params tlsServer tlsClient writeChan startQueue d readChan resultQueue runTLSPipeSimple :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString runTLSPipeSimple params bs = runTLSPipe params tlsServer tlsClient bs 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 () benchConnection :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d benchResumption :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption params !d name = env initializeSession runResumption where initializeSession = do sessionRef <- newIORef Nothing let sessionManager = oneSessionManager sessionRef params1 = setPairParamsSessionManager sessionManager params _ <- runTLSPipeSimple params1 d Just sessionParams <- readIORef sessionRef let params2 = setPairParamsSessionResuming sessionParams params1 newIORef params2 runResumption paramsRef = bench name . nfIO $ do params2 <- readIORef paramsRef runTLSPipeSimple params2 d main :: IO () main = defaultMain [ bgroup "connection" -- not sure the number actually make sense for anything. improve .. [ benchConnection (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" , benchConnection (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" , benchConnection (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" , benchConnection (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" ] , bgroup "resumption" [ benchResumption (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" , benchResumption (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" , benchResumption (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" , benchResumption (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" ] ] tls-1.4.1/LICENSE0000644000000000000000000000273113100036227011507 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.4.1/Setup.hs0000644000000000000000000000005613100036227012134 0ustar0000000000000000import Distribution.Simple main = defaultMain tls-1.4.1/tls.cabal0000644000000000000000000001406713246067023012306 0ustar0000000000000000Name: tls Version: 1.4.1 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 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.7 && < 5 , mtl >= 2 , transformers , cereal >= 0.4 , bytestring , data-default-class -- crypto related , memory >= 0.14.6 , cryptonite >= 0.24 -- certificate related , asn1-types >= 0.2.0 , asn1-encoding , x509 >= 1.7.1 , x509-store >= 1.6 , x509-validation >= 1.6.5 , async >= 2.0 if flag(network) Build-Depends: network >= 2.4.0.0 cpp-options: -DINCLUDE_NETWORK if flag(hans) Build-Depends: hans cpp-options: -DINCLUDE_HANS Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher Network.TLS.Extra.FFDHE other-modules: Network.TLS.Cap Network.TLS.Struct Network.TLS.Core Network.TLS.Context Network.TLS.Context.Internal Network.TLS.Credentials Network.TLS.Backend Network.TLS.Crypto Network.TLS.Crypto.DH Network.TLS.Crypto.IES Network.TLS.Crypto.Types Network.TLS.ErrT Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Common Network.TLS.Handshake.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 if flag(compat) cpp-options: -DSSLV2_COMPATIBLE Test-Suite test-tls type: exitcode-stdio-1.0 hs-source-dirs: Tests Main-is: Tests.hs other-modules: Certificate Ciphers Connection Marshalling PipeChan PubKey Build-Depends: base >= 3 && < 5 , mtl , cereal >= 0.3 , data-default-class , tasty , tasty-quickcheck , tls , QuickCheck , cryptonite , bytestring , asn1-types , x509 , x509-validation , hourglass ghc-options: -Wall -fno-warn-unused-imports Benchmark bench-tls hs-source-dirs: Benchmarks Tests Main-Is: Benchmarks.hs type: exitcode-stdio-1.0 Build-depends: base >= 4 && < 5 , tls , x509 , x509-validation , data-default-class , cryptonite , criterion >= 1.0 , mtl , bytestring , asn1-types , hourglass , QuickCheck >= 2 , tasty-quickcheck , tls ghc-options: -Wall -fno-warn-unused-imports source-repository head type: git location: https://github.com/vincenthz/hs-tls subdir: core tls-1.4.1/CHANGELOG.md0000644000000000000000000002040613240574164012326 0ustar0000000000000000## Version 1.4.1 - Enable X25519 in default parameters [#265](https://github.com/vincenthz/hs-tls/pull/265) - Checking EOF in bye [#262] (https://github.com/vincenthz/hs-tls/pull/262) - Improving validation in DH key exchange [#256](https://github.com/vincenthz/hs-tls/pull/256) - Handle TCP reset during handshake [#251](https://github.com/vincenthz/hs-tls/pull/251) - Accepting hlint suggestions. ## Version 1.4.0 - Wrap renegotiation failures with HandshakeFailed [#237](https://github.com/vincenthz/hs-tls/pull/237) - Improve selection of server certificate and use "signature_algorithms" extension [#236](https://github.com/vincenthz/hs-tls/pull/236) - Change Bytes to ByteString and deprecate the Bytes type alias [#230](https://github.com/vincenthz/hs-tls/pull/230) - Session compression and SNI [#223](https://github.com/vincenthz/hs-tls/pull/223) - Deprecating ciphersuite_medium. Putting WARNING to ciphersuite_all since this includes RC4 [#153](https://github.com/vincenthz/hs-tls/pull/153) [#222](https://github.com/vincenthz/hs-tls/pull/222) - Removing NPN [#214](https://github.com/vincenthz/hs-tls/pull/214) - Supporting RSAPSS defined in TLS 1.3 [#207](https://github.com/vincenthz/hs-tls/pull/207) - Supporting X25519 and X448 in the IES style. [#205](https://github.com/vincenthz/hs-tls/pull/205) - Strip leading zeros in DHE premaster secret [#201](https://github.com/vincenthz/hs-tls/pull/201) FEATURES: - RSASSA-PSS signatures can be enabled with `supportedHashSignatures`. This uses assignments from TLS 1.3, for example `(HashIntrinsic, SignatureRSApssSHA256)`. - Diffie-Hellman with elliptic curves X25519 and X448: This can be enabled with `supportedGroups`, which also gives control over curve preference. - ECDH with curve P-256 now uses optimized C implementation from package `cryptonite`. API CHANGES: - Cipher list `ciphersuite_medium` is now deprecated, users are advised to use `ciphersuite_default` or `ciphersuite_strong`. List `ciphersuite_all` is kept for compatibility with old servers but this is discouraged and generates a warning (this includes RC4 ciphers, see [#153](https://github.com/vincenthz/hs-tls/pull/153) for reference). - Support for NPN (Next Protocol Negotiation) has been removed. The replacement is ALPN (Application-Layer Protocol Negotiation). - Data type `SessionData` now contains fields for compression algorithm and client SNI. A `SessionManager` implementation that serializes/deserializes `SessionData` values must deal with the new fields. - Module `Network.TLS` exports a type alias named `Bytes` which is now deprecated. The replacement is to use strict `ByteString` directly. ## Version 1.3.11 - Using reliable versions of dependent libraries. ## Version 1.3.10 - Selecting a cipher based on "signature_algorithms" [#193](https://github.com/vincenthz/hs-tls/pull/193) - Respecting the "signature_algorithms" extension [#137](https://github.com/vincenthz/hs-tls/pull/137) - Fix RSA signature in CertificateVerify with TLS < 1.2 [#189](https://github.com/vincenthz/hs-tls/pull/189) - Fix ECDSA with TLS 1.0 / TLS 1.1 [#187](https://github.com/vincenthz/hs-tls/pull/187) - Sending an empty server name from a server if necessary. [#175](https://github.com/vincenthz/hs-tls/pull/175) - `Network.TLS.Extra` provides Finite Field Diffie-Hellman Ephemeral Parameters in RFC 7919 [#174](https://github.com/vincenthz/hs-tls/pull/174) - Restore ability to renegotiate[#164](https://github.com/vincenthz/hs-tls/pull/164) ## Version 1.3.9 - Drop support for old GHC. - Enable sha384 ciphers and provide `ciphersuite_default` as default set of ciphers for common needs [#168](https://github.com/vincenthz/hs-tls/pull/168) - SNI late checks [#147](https://github.com/vincenthz/hs-tls/pull/147) - Expose the HasBackend(..) class fully, so that developers can use TLS over their own channels [#149](https://github.com/vincenthz/hs-tls/pull/149) ## Version 1.3.8 - Fix older GHC builds ## Version 1.3.7 - Disable SHA384 based cipher, as they don't work properly yet. ## Version 1.3.6 - Add new ciphers - Improve some debugging and outputs ## Version 1.3.5 - Fix a bug with ECDHE based cipher where serialization - Debugging: Add a way to print random seed and a way to side-load a seed for replayability - Improve tests ## Version 1.3.4 - Fix tests on 32 bits `time_t` machines (time not within bound) - VirtualHost: Add a way to load credentials related to the hostname used by the client (Julian Beaumont) - VirtualHost: Expose an API to query which hostname the client has contacted (Julian Beaumont) - Add a way to disable empty packet that are use for security when using old versions + old CBC based cipher (Anton Dessiatov) ## Version 1.3.3 - Add support for Hans (Haskell Network Stack) (Adam Wick) - Add support for ECDSA signature - Add support for ECDSA-ECDHE Cipher - Improve parsing of ECC related structure ## Version 1.3.2 - Add cipher suites for forward secrecy on more clients (Aaron Friel) - Maintain more handshake information to be queried by protocol (Adam Wick) - handle SCSV on client and server side (Kazu Yamamoto) - Cleanup renegotiation logic (Kazu Yamamoto) - Various testing improvements with the openssl test parts - Cleanup AEAD handling for future support of other ciphers ## Version 1.3.1 - Repair DHE RSA handling on the cipher by creating signature properly ## Version 1.3.0 - modernize the crypto stack by using cryptonite. ## Version 1.2.18 - add more tests (network, local) - cleanup cipher / bulk code, certificate verify / creation, and digitall signed handling - fix handling of DHE ciphers with MS SSL stack that serialize leading zero. ## Version 1.2.17 - Fix an issue of type of key / hash that prevented connection with SChannel. ## Version 1.2.16 - Fix an issue with stream cipher not correctly calculating the internal state, resulting systematically in bad record mac failure during handshake ## Version 1.2.15 - support chain certificate in credentials ## Version 1.2.14 - adding ALPN extension - adding support for AEAD, and particularly AES128-GCM - Adding support for ECDH - Do not support SSL3 by default for security reason. - add EnumSafe8 and 16 for specific sized Enum instance that are safer - export signatureAndHash parser/encoder - add a "known" list of extensions - add SignatureAlgorithms extension - add Heartbeat extension - add support for EC curves and point format extensions - add preliminary SessionTicket extension - Debug: Add the ability to choose arbitrary cipher in the client hello. ## Version 1.2.13 - Fix compilation with old mtl version ## Version 1.2.12 - Propagate asynchronous exception ## Version 1.2.11 - use hourglass instead of time - use tasty instead of test-framework - add travis file - remove old de-optimisation flag as the bytestring bug is old now and it conflict with cabal check ## Version 1.2.10 - Update x509 dependencies ## Version 1.2.9 - Export TLSParams and HasBackend type names - Added FlexibleContexts flag required by ghc-7.9 - debug: add support for specifying the timeout length in milliseconds. - debug: add support for 3DES in simple client ## Version 1.2.8 - add support for 3DES-EDE-CBC-SHA1 (cipher 0xa) ## Version 1.2.7 - repair retrieve certificate validation, and improve fingerprints - remove groom from dependency - make RecordM an instance of Applicative - Fixes the Error_EOF partial pattern match error in exception handling ## Version 1.2.6 (23 Mar 2014) - Fixed socket backend endless loop when the server does not close connection properly at the TLS level with the close notify alert. - Catch Error_EOF in recvData and return empty data. ## Version 1.2.5 (23 Mar 2014) - Fixed Server key exchange data being parsed without the correct context, leading to not knowing how to parse the structure. The bug happens on efficient server that happens to send the ServerKeyXchg message together with the ServerHello in the same handshake packet. This trigger parsing of all the messages without having set the pending cipher. Delay parsing, when this happen, until we know what to do with it. ## Version 1.2.4 (23 Mar 2014) - Fixed unrecognized name non-fatal alert after client hello. - Add SSL3 to the supported list of version by default. - Fix cereal lower bound to 0.4.0 minimum ## Version 1.2.3 (22 Mar 2014) - Fixed handshake records not being able to span multiples records.