tls-1.1.5/0000755000000000000000000000000012213013270010475 5ustar0000000000000000tls-1.1.5/LICENSE0000644000000000000000000000273112213013270011505 0ustar0000000000000000Copyright (c) 2010-2012 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.1.5/Setup.hs0000644000000000000000000000005612213013270012132 0ustar0000000000000000import Distribution.Simple main = defaultMain tls-1.1.5/tls.cabal0000644000000000000000000000737012213013270012272 0ustar0000000000000000Name: tls Version: 1.1.5 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, with only RSA supported for Key Exchange. . Only core protocol available here, have a look at the package for default ciphers, compressions and certificates functions. 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 Flag compat Description: Accept SSLv2 compatible handshake Default: True Library Build-Depends: base >= 3 && < 5 , mtl , cryptohash >= 0.6 , cereal >= 0.3 , bytestring , network , crypto-random >= 0.0.7 && < 0.1 , crypto-pubkey >= 0.2 , certificate >= 1.3.0 && < 1.4.0 Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression Network.TLS.Internal other-modules: Network.TLS.Cap Network.TLS.Struct Network.TLS.Core Network.TLS.Context Network.TLS.Crypto Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Common Network.TLS.Handshake.Certificate Network.TLS.Handshake.Client Network.TLS.Handshake.Server Network.TLS.Handshake.Signature Network.TLS.IO Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet Network.TLS.Record Network.TLS.Record.Types Network.TLS.Record.Engage Network.TLS.Record.Disengage Network.TLS.State Network.TLS.Session Network.TLS.Sending Network.TLS.Receiving Network.TLS.Util Network.TLS.Types Network.TLS.Wire ghc-options: -Wall if impl(ghc == 7.6.1) ghc-options: -O0 if flag(compat) cpp-options: -DSSLV2_COMPATIBLE Test-Suite test-tls type: exitcode-stdio-1.0 hs-source-dirs: Tests Main-is: Tests.hs Build-Depends: base >= 3 && < 5 , mtl , cereal >= 0.3 , QuickCheck >= 2 , test-framework , test-framework-quickcheck2 , cprng-aes >= 0.5 , crypto-pubkey , bytestring , certificate , tls , time , crypto-random >= 0.0.2 && < 0.1 ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures source-repository head type: git location: git://github.com/vincenthz/hs-tls tls-1.1.5/Network/0000755000000000000000000000000012213013270012126 5ustar0000000000000000tls-1.1.5/Network/TLS.hs0000644000000000000000000000446312213013270013133 0ustar0000000000000000-- | -- Module : Network.TLS -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS ( -- * Context configuration Params(..) , RoleParams(..) , ClientParams(..) , ServerParams(..) , updateClientParams , updateServerParams , Logging(..) , Measurement(..) , CertificateUsage(..) , CertificateRejectReason(..) , defaultParamsClient , defaultParamsServer , defaultLogging , MaxFragmentEnum(..) , HashAndSignatureAlgorithm , HashAlgorithm(..) , SignatureAlgorithm(..) , CertificateType(..) -- * raw types , ProtocolType(..) , Header(..) -- * Session , SessionID , SessionData(..) , SessionManager(..) , NoSessionManager(..) , setSessionManager -- * Backend abstraction , Backend(..) -- * Context object , Context , ctxConnection -- * Creating a context , contextNew , contextNewOnHandle , contextFlush , contextClose -- * deprecated type aliases , TLSParams , TLSLogging , TLSCertificateUsage , TLSCertificateRejectReason , TLSCtx -- * deprecated values , defaultParams -- * Initialisation and Termination of context , bye , handshake -- * Next Protocol Negotiation , getNegotiatedProtocol -- * High level API , sendData , recvData , recvData' -- * Crypto Key , PrivateKey(..) -- * Compressions & Predefined compressions , module Network.TLS.Compression -- * Ciphers & Predefined ciphers , module Network.TLS.Cipher -- * Versions , Version(..) -- * Errors , TLSError(..) , KxError(..) , AlertDescription(..) -- * Exceptions , Terminated(..) , HandshakeFailed(..) , ConnectionNotEstablished(..) ) where import Network.TLS.Struct (Version(..), TLSError(..), HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..), Header(..), ProtocolType(..), CertificateType(..), AlertDescription(..)) import Network.TLS.Crypto (PrivateKey(..), KxError(..)) import Network.TLS.Cipher import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) import Network.TLS.Context import Network.TLS.Core import Network.TLS.Session tls-1.1.5/Network/TLS/0000755000000000000000000000000012213013270012570 5ustar0000000000000000tls-1.1.5/Network/TLS/Struct.hs0000644000000000000000000004007612213013270014417 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 -- module Network.TLS.Struct ( Bytes , Version(..) , ConnectionEnd(..) , CipherType(..) , CipherData(..) , ExtensionID , ExtensionRaw , CertificateType(..) , HashAlgorithm(..) , SignatureAlgorithm(..) , HashAndSignatureAlgorithm , ProtocolType(..) , TLSError(..) , DistinguishedName , ServerDHParams(..) , ServerRSAParams(..) , ServerKeyXchgAlgorithmData(..) , Packet(..) , Header(..) , ServerRandom(..) , ClientRandom(..) , serverRandom , clientRandom , FinishedData , SessionID , Session(..) , SessionData(..) , CertVerifyData(..) , AlertLevel(..) , AlertDescription(..) , HandshakeType(..) , Handshake(..) , numericalVer , verOfNum , TypeValuable, valOfType, valToType , packetType , typeOfHandshake ) where import Data.ByteString (ByteString) import qualified Data.ByteString as B (length) import Data.Word import Data.Certificate.X509 (X509) import Data.Certificate.X509.Cert (DistinguishedName) import Data.Typeable import Control.Monad.Error (Error(..)) import Control.Exception (Exception(..)) import Network.TLS.Types type Bytes = ByteString data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD data CipherData = CipherData { cipherDataContent :: Bytes , cipherDataMAC :: Maybe Bytes , cipherDataPadding :: Maybe Bytes } deriving (Show,Eq) data CertificateType = CertificateType_RSA_Sign -- TLS10 | CertificateType_DSS_Sign -- TLS10 | CertificateType_RSA_Fixed_DH -- TLS10 | CertificateType_DSS_Fixed_DH -- TLS10 | CertificateType_RSA_Ephemeral_DH -- TLS12 | CertificateType_DSS_Ephemeral_DH -- TLS12 | CertificateType_fortezza_dms -- TLS12 | CertificateType_Unknown Word8 deriving (Show,Eq) data HashAlgorithm = HashNone | HashMD5 | HashSHA1 | HashSHA224 | HashSHA256 | HashSHA384 | HashSHA512 | HashOther Word8 deriving (Show,Eq) data SignatureAlgorithm = SignatureAnonymous | SignatureRSA | SignatureDSS | SignatureECDSA | SignatureOther Word8 deriving (Show,Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) 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) instance Error TLSError where noMsg = Error_Misc "" strMsg = Error_Misc instance Exception TLSError 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 Bytes deriving (Show, Eq) newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq) newtype Session = Session (Maybe SessionID) deriving (Show, Eq) type FinishedData = Bytes type ExtensionID = Word16 type ExtensionRaw = (ExtensionID, Bytes) newtype CertVerifyData = CertVerifyData Bytes deriving (Show, Eq) constrRandom32 :: (Bytes -> a) -> Bytes -> Maybe a constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing serverRandom :: Bytes -> Maybe ServerRandom serverRandom l = constrRandom32 ServerRandom l clientRandom :: Bytes -> Maybe ClientRandom clientRandom l = constrRandom32 ClientRandom l data AlertLevel = AlertLevel_Warning | AlertLevel_Fatal deriving (Show,Eq) data AlertDescription = CloseNotify | UnexpectedMessage | BadRecordMac | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation | RecordOverflow | DecompressionFailure | HandshakeFailure | BadCertificate | UnsupportedCertificate | CertificateRevoked | CertificateExpired | CertificateUnknown | IllegalParameter | UnknownCa | AccessDenied | DecodeError | DecryptError | ExportRestriction | ProtocolVersion | InsufficientSecurity | InternalError | UserCanceled | NoRenegotiation | UnsupportedExtension | CertificateUnobtainable | UnrecognizedName | BadCertificateStatusResponse | BadCertificateHashValue deriving (Show,Eq) data HandshakeType = HandshakeType_HelloRequest | HandshakeType_ClientHello | HandshakeType_ServerHello | HandshakeType_Certificate | HandshakeType_ServerKeyXchg | HandshakeType_CertRequest | HandshakeType_ServerHelloDone | HandshakeType_CertVerify | HandshakeType_ClientKeyXchg | HandshakeType_Finished | HandshakeType_NPN -- Next Protocol Negotiation extension deriving (Show,Eq) data ServerDHParams = ServerDHParams { dh_p :: Integer -- ^ prime modulus , dh_g :: Integer -- ^ generator , dh_Ys :: Integer -- ^ public value (g^X mod p) } 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 [Word8] | SKX_DHE_RSA ServerDHParams [Word8] | SKX_RSA (Maybe ServerRSAParams) | SKX_DH_DSS (Maybe ServerRSAParams) | SKX_DH_RSA (Maybe ServerRSAParams) | SKX_Unknown Bytes 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 [X509] | HelloRequest | ServerHelloDone | ClientKeyXchg Bytes | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [ HashAndSignatureAlgorithm ]) [DistinguishedName] | CertVerify (Maybe HashAndSignatureAlgorithm) CertVerifyData | Finished FinishedData | HsNextProtocolNegotiation Bytes -- NPN extension deriving (Show,Eq) packetType :: Packet -> ProtocolType packetType (Handshake _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData typeOfHandshake :: Handshake -> HandshakeType typeOfHandshake (ClientHello {}) = HandshakeType_ClientHello typeOfHandshake (ServerHello {}) = HandshakeType_ServerHello typeOfHandshake (Certificates {}) = HandshakeType_Certificate typeOfHandshake HelloRequest = HandshakeType_HelloRequest typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone typeOfHandshake (ClientKeyXchg {}) = HandshakeType_ClientKeyXchg typeOfHandshake (ServerKeyXchg {}) = HandshakeType_ServerKeyXchg typeOfHandshake (CertRequest {}) = HandshakeType_CertRequest typeOfHandshake (CertVerify {}) = HandshakeType_CertVerify typeOfHandshake (Finished {}) = HandshakeType_Finished typeOfHandshake (HsNextProtocolNegotiation {}) = HandshakeType_NPN numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) numericalVer SSL3 = (3, 0) numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3) verOfNum :: (Word8, Word8) -> Maybe Version verOfNum (2, 0) = Just SSL2 verOfNum (3, 0) = Just SSL3 verOfNum (3, 1) = Just TLS10 verOfNum (3, 2) = Just TLS11 verOfNum (3, 3) = Just TLS12 verOfNum _ = Nothing class TypeValuable a where valOfType :: a -> Word8 valToType :: Word8 -> Maybe a instance TypeValuable ConnectionEnd where valOfType ConnectionServer = 0 valOfType ConnectionClient = 1 valToType 0 = Just ConnectionServer valToType 1 = Just ConnectionClient valToType _ = Nothing instance TypeValuable CipherType where valOfType CipherStream = 0 valOfType CipherBlock = 1 valOfType CipherAEAD = 2 valToType 0 = Just CipherStream valToType 1 = Just CipherBlock valToType 2 = Just CipherAEAD valToType _ = Nothing instance TypeValuable ProtocolType where valOfType ProtocolType_ChangeCipherSpec = 20 valOfType ProtocolType_Alert = 21 valOfType ProtocolType_Handshake = 22 valOfType ProtocolType_AppData = 23 valOfType ProtocolType_DeprecatedHandshake = 128 -- unused valToType 20 = Just ProtocolType_ChangeCipherSpec valToType 21 = Just ProtocolType_Alert valToType 22 = Just ProtocolType_Handshake valToType 23 = Just ProtocolType_AppData valToType _ = Nothing instance TypeValuable HandshakeType where valOfType HandshakeType_HelloRequest = 0 valOfType HandshakeType_ClientHello = 1 valOfType HandshakeType_ServerHello = 2 valOfType HandshakeType_Certificate = 11 valOfType HandshakeType_ServerKeyXchg = 12 valOfType HandshakeType_CertRequest = 13 valOfType HandshakeType_ServerHelloDone = 14 valOfType HandshakeType_CertVerify = 15 valOfType HandshakeType_ClientKeyXchg = 16 valOfType HandshakeType_Finished = 20 valOfType HandshakeType_NPN = 67 valToType 0 = Just HandshakeType_HelloRequest valToType 1 = Just HandshakeType_ClientHello valToType 2 = Just HandshakeType_ServerHello valToType 11 = Just HandshakeType_Certificate valToType 12 = Just HandshakeType_ServerKeyXchg valToType 13 = Just HandshakeType_CertRequest valToType 14 = Just HandshakeType_ServerHelloDone valToType 15 = Just HandshakeType_CertVerify valToType 16 = Just HandshakeType_ClientKeyXchg valToType 20 = Just HandshakeType_Finished valToType 67 = Just HandshakeType_NPN valToType _ = Nothing instance TypeValuable AlertLevel where valOfType AlertLevel_Warning = 1 valOfType AlertLevel_Fatal = 2 valToType 1 = Just AlertLevel_Warning valToType 2 = Just AlertLevel_Fatal valToType _ = Nothing instance TypeValuable AlertDescription where valOfType CloseNotify = 0 valOfType UnexpectedMessage = 10 valOfType BadRecordMac = 20 valOfType DecryptionFailed = 21 valOfType RecordOverflow = 22 valOfType DecompressionFailure = 30 valOfType HandshakeFailure = 40 valOfType BadCertificate = 42 valOfType UnsupportedCertificate = 43 valOfType CertificateRevoked = 44 valOfType CertificateExpired = 45 valOfType CertificateUnknown = 46 valOfType IllegalParameter = 47 valOfType UnknownCa = 48 valOfType AccessDenied = 49 valOfType DecodeError = 50 valOfType DecryptError = 51 valOfType ExportRestriction = 60 valOfType ProtocolVersion = 70 valOfType InsufficientSecurity = 71 valOfType InternalError = 80 valOfType 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 90 = Just UserCanceled valToType 100 = Just NoRenegotiation valToType 110 = Just UnsupportedExtension valToType 111 = Just CertificateUnobtainable valToType 112 = Just UnrecognizedName valToType 113 = Just BadCertificateStatusResponse valToType 114 = Just BadCertificateHashValue valToType _ = Nothing instance TypeValuable CertificateType where valOfType CertificateType_RSA_Sign = 1 valOfType CertificateType_DSS_Sign = 2 valOfType CertificateType_RSA_Fixed_DH = 3 valOfType CertificateType_DSS_Fixed_DH = 4 valOfType CertificateType_RSA_Ephemeral_DH = 5 valOfType CertificateType_DSS_Ephemeral_DH = 6 valOfType CertificateType_fortezza_dms = 20 valOfType (CertificateType_Unknown i) = i valToType 1 = Just CertificateType_RSA_Sign valToType 2 = Just CertificateType_DSS_Sign valToType 3 = Just CertificateType_RSA_Fixed_DH valToType 4 = Just CertificateType_DSS_Fixed_DH valToType 5 = Just CertificateType_RSA_Ephemeral_DH valToType 6 = Just CertificateType_DSS_Ephemeral_DH valToType 20 = Just CertificateType_fortezza_dms valToType i = Just (CertificateType_Unknown i) instance TypeValuable HashAlgorithm where valOfType HashNone = 0 valOfType HashMD5 = 1 valOfType HashSHA1 = 2 valOfType HashSHA224 = 3 valOfType HashSHA256 = 4 valOfType HashSHA384 = 5 valOfType HashSHA512 = 6 valOfType (HashOther i) = i valToType 0 = Just HashNone valToType 1 = Just HashMD5 valToType 2 = Just HashSHA1 valToType 3 = Just HashSHA224 valToType 4 = Just HashSHA256 valToType 5 = Just HashSHA384 valToType 6 = Just HashSHA512 valToType i = Just (HashOther i) instance TypeValuable SignatureAlgorithm where valOfType SignatureAnonymous = 0 valOfType SignatureRSA = 1 valOfType SignatureDSS = 2 valOfType SignatureECDSA = 3 valOfType (SignatureOther i) = i valToType 0 = Just SignatureAnonymous valToType 1 = Just SignatureRSA valToType 2 = Just SignatureDSS valToType 3 = Just SignatureECDSA valToType i = Just (SignatureOther i) tls-1.1.5/Network/TLS/Sending.hs0000644000000000000000000001020312213013270014507 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, encryptRSA, signRSA) where import Control.Applicative ((<$>)) import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Util import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Crypto {- - 'makePacketData' create a Header and a content bytestring related to a packet - this doesn't change any state -} makeRecord :: Packet -> TLSSt (Record Plaintext) makeRecord pkt = do ver <- stVersion <$> get content <- writePacketContent pkt return $ Record (packetType pkt) ver (fragmentPlaintext content) {- - ChangeCipherSpec state change need to be handled after encryption otherwise - its own packet would be encrypted with the new context, instead of beeing sent - under the current context -} postprocessRecord :: Record Ciphertext -> TLSSt (Record Ciphertext) postprocessRecord record@(Record ProtocolType_ChangeCipherSpec _ _) = switchTxEncryption >> return record postprocessRecord record = return record {- - marshall packet data -} encodeRecord :: Record Ciphertext -> TLSSt ByteString encodeRecord record = return $ B.concat [ encodeHeader hdr, content ] where (hdr, content) = recordToRaw record {- - just update TLS state machine -} preProcessPacket :: Packet -> TLSSt () preProcessPacket (Alert _) = return () preProcessPacket (AppData _) = return () preProcessPacket (ChangeCipherSpec) = return () preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do case hs of Finished fdata -> updateVerifiedData True fdata _ -> return () when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage $ encodeHandshake hs when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) {- - writePacket transform a packet into marshalled data related to current state - and updating state on the go -} writePacket :: Packet -> TLSSt ByteString writePacket pkt = do preProcessPacket pkt makeRecord pkt >>= engageRecord >>= postprocessRecord >>= encodeRecord {------------------------------------------------------------------------------} {- SENDING Helpers -} {------------------------------------------------------------------------------} {- 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 :: ByteString -> TLSSt ByteString encryptRSA content = do st <- get let rsakey = fromJust "rsa public key" $ hstRSAPublicKey $ fromJust "handshake" $ stHandshake st (v,rng') = withTLSRNG (stRandomGen st) (\g -> kxEncrypt g rsakey content) in do put (st { stRandomGen = rng' }) case v of Left err -> fail ("rsa encrypt failed: " ++ show err) Right econtent -> return econtent signRSA :: HashDescr -> ByteString -> TLSSt ByteString signRSA hsh content = do st <- get let rsakey = fromJust "rsa client private key" $ hstRSAClientPrivateKey $ fromJust "handshake" $ stHandshake st let (r, rng') = withTLSRNG (stRandomGen st) (\g -> kxSign g rsakey hsh content) put (st { stRandomGen = rng' }) case r of Left err -> fail ("rsa sign failed: " ++ show err) Right econtent -> return econtent writePacketContent :: Packet -> TLSSt ByteString writePacketContent (Handshake hss) = return $ encodeHandshakes hss writePacketContent (Alert a) = return $ encodeAlerts a writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec writePacketContent (AppData x) = return x tls-1.1.5/Network/TLS/Compression.hs0000644000000000000000000000517112213013270015431 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Network.TLS.Compression -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Compression ( CompressionC(..) , Compression(..) , CompressionID , nullCompression , NullCompression -- * member redefined for the class abstraction , compressionID , compressionDeflate , compressionInflate -- * helper , compressionIntersectID ) where import Data.Word import Network.TLS.Types (CompressionID) import Data.ByteString (ByteString) import Control.Arrow (first) -- | supported compression algorithms need to be part of this class class CompressionC a where compressionCID :: a -> CompressionID compressionCDeflate :: a -> ByteString -> (a, ByteString) compressionCInflate :: a -> ByteString -> (a, ByteString) -- | every compression need to be wrapped in this, to fit in structure data Compression = forall a . CompressionC a => Compression a -- | return the associated ID for this algorithm compressionID :: Compression -> CompressionID compressionID (Compression c) = compressionCID c -- | deflate (compress) a bytestring using a compression context and return the result -- along with the new compression context. compressionDeflate :: ByteString -> Compression -> (Compression, ByteString) compressionDeflate bytes (Compression c) = first Compression $ compressionCDeflate c bytes -- | inflate (decompress) a bytestring using a compression context and return the result -- along the new compression context. compressionInflate :: ByteString -> Compression -> (Compression, ByteString) compressionInflate bytes (Compression c) = first Compression $ compressionCInflate c bytes instance Show Compression where show = show . compressionID -- | intersect a list of ids commonly given by the other side with a list of compression -- the function keeps the list of compression in order, to be able to find quickly the prefered -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> elem (compressionID c) ids) l -- | This is the default compression which is a NOOP. data NullCompression = NullCompression instance CompressionC NullCompression where compressionCID _ = 0 compressionCDeflate s b = (s, b) compressionCInflate s b = (s, b) -- | default null compression nullCompression :: Compression nullCompression = Compression NullCompression tls-1.1.5/Network/TLS/Core.hs0000644000000000000000000001303112213013270014012 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable, 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 , HandshakeFailed(..) , ConnectionNotEstablished(..) -- * Next Protocol Negotiation , getNegotiatedProtocol -- * High level API , Terminated(..) , sendData , recvData , recvData' ) where import Network.TLS.Context import Network.TLS.Struct import Network.TLS.State (getSession) import Network.TLS.IO import Network.TLS.Session import Network.TLS.Handshake import Data.Typeable import qualified Network.TLS.State as S import qualified Data.ByteString as B import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E import Control.Monad.State -- | Early termination exception with the reason and the TLS error associated data Terminated = Terminated Bool String TLSError deriving (Eq,Show,Typeable) instance E.Exception Terminated -- | notify the context that this side wants to close connection. -- this is important that it is called before closing the handle, otherwise -- the session might not be resumable (for version < TLS1.2). -- -- this doesn't actually close the handle bye :: MonadIO m => Context -> m () bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the Next Protocol Negotiation extension has been used, this will -- return get the protocol agreed upon. getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString) getNegotiatedProtocol ctx = usingState_ ctx S.getNegotiatedProtocol -- | 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 = 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 = checkValid ctx >> recvPacket ctx >>= either onError process where 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 {})]) = -- on server context receiving a client hello == renegotiation case roleParams $ ctxParams ctx of Server sparams -> handshakeServerWith sparams ctx ch >> recvData ctx Client {} -> let reason = "unexpected client hello in client context" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason process (Handshake [HelloRequest]) = -- on client context, receiving a hello request == renegotiation case roleParams $ ctxParams ctx of Server {} -> let reason = "unexpected hello request in server context" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Client cparams -> handshakeClient cparams ctx >> recvData ctx process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx liftIO $ 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 :: MonadIO m => TLSError -> AlertLevel -> AlertDescription -> String -> m a terminate err level desc reason = do session <- usingState_ ctx getSession case session of Session Nothing -> return () Session (Just sid) -> withSessionManager (ctxParams ctx) (\s -> liftIO $ sessionInvalidate s sid) liftIO $ E.catch (sendPacket ctx $ Alert [(level, desc)]) (\(_ :: E.SomeException) -> return ()) setEOF ctx liftIO $ 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 = liftIO $ E.catch (bye ctx) (\(_ :: E.SomeException) -> 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.1.5/Network/TLS/State.hs0000644000000000000000000005456712213013270014225 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, MultiParamTypeClasses, ExistentialQuantification, RankNTypes, CPP #-} -- | -- 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 , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..) , newTLSState , genTLSRandom , withTLSRNG , withCompression , assert -- FIXME move somewhere else (Internal.hs ?) , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial , certVerifyHandshakeTypeMaterial , certVerifyHandshakeMaterial , makeDigest , setMasterSecret , setMasterSecretFromPre , getMasterSecret , setPublicKey , setPrivateKey , setClientPublicKey , setClientPrivateKey , setClientCertSent , getClientCertSent , setCertReqSent , getCertReqSent , setClientCertChain , getClientCertChain , setClientCertRequest , getClientCertRequest , setKeyBlock , setVersion , setCipher , setServerRandom , setSecureRenegotiation , getSecureRenegotiation , setExtensionNPN , getExtensionNPN , setNegotiatedProtocol , getNegotiatedProtocol , setServerNextProtocolSuggest , getServerNextProtocolSuggest , getClientCertificateChain , setClientCertificateChain , getVerifiedData , setSession , getSession , getSessionData , isSessionResuming , needEmptyPacket , switchTxEncryption , switchRxEncryption , getCipherKeyExchangeType , isClientContext , startHandshakeClient , addHandshakeMessage , updateHandshakeDigest , getHandshakeDigest , getHandshakeMessages , endHandshake ) where import Data.Word import Data.Maybe (isNothing) import Network.TLS.Util import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.Crypto import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.MAC import qualified Data.ByteString as B import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.State import Control.Monad.Error import Crypto.Random.API import Data.Certificate.X509 assert :: Monad m => String -> [(String,Bool)] -> m () assert fctname list = forM_ list $ \ (name, assumption) -> do when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") data TLSCryptState = TLSCryptState { cstKey :: !Bytes , cstIV :: !Bytes , cstMacSecret :: !Bytes } deriving (Show) data TLSMacState = TLSMacState { msSequence :: Word64 } deriving (Show) type ClientCertRequestData = ([CertificateType], Maybe [(HashAlgorithm, SignatureAlgorithm)], [DistinguishedName]) data TLSHandshakeState = TLSHandshakeState { hstClientVersion :: !(Version) , hstClientRandom :: !ClientRandom , hstServerRandom :: !(Maybe ServerRandom) , hstMasterSecret :: !(Maybe Bytes) , hstRSAPublicKey :: !(Maybe PublicKey) , hstRSAPrivateKey :: !(Maybe PrivateKey) , hstRSAClientPublicKey :: !(Maybe PublicKey) , hstRSAClientPrivateKey :: !(Maybe PrivateKey) , hstHandshakeDigest :: !HashCtx , hstHandshakeMessages :: [Bytes] , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent , hstClientCertChain :: !(Maybe [X509]) } deriving (Show) data StateRNG = forall g . CPRG g => StateRNG g instance Show StateRNG where show _ = "rng[..]" data TLSState = TLSState { stClientContext :: Bool , stVersion :: !Version , stHandshake :: !(Maybe TLSHandshakeState) , stSession :: Session , stSessionResuming :: Bool , stTxEncrypted :: Bool , stRxEncrypted :: Bool , stActiveTxCryptState :: !(Maybe TLSCryptState) , stActiveRxCryptState :: !(Maybe TLSCryptState) , stPendingTxCryptState :: !(Maybe TLSCryptState) , stPendingRxCryptState :: !(Maybe TLSCryptState) , stActiveTxMacState :: !(Maybe TLSMacState) , stActiveRxMacState :: !(Maybe TLSMacState) , stPendingTxMacState :: !(Maybe TLSMacState) , stPendingRxMacState :: !(Maybe TLSMacState) , stActiveTxCipher :: Maybe Cipher , stActiveRxCipher :: Maybe Cipher , stPendingCipher :: Maybe Cipher , stCompression :: Compression , stRandomGen :: StateRNG , stSecureRenegotiation :: Bool -- RFC 5746 , stClientVerifiedData :: Bytes -- RFC 5746 , stServerVerifiedData :: Bytes -- RFC 5746 , stExtensionNPN :: Bool -- NPN draft extension , stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol , stServerNextProtocolSuggest :: Maybe [B.ByteString] , stClientCertificateChain :: Maybe [X509] } deriving (Show) newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a } deriving (Monad, MonadError TLSError) instance Functor TLSSt where fmap f = TLSSt . fmap f . runTLSSt 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 (runErrorT (runTLSSt f)) st newTLSState :: CPRG g => g -> TLSState newTLSState rng = TLSState { stClientContext = False , stVersion = TLS10 , stHandshake = Nothing , stSession = Session Nothing , stSessionResuming = False , stTxEncrypted = False , stRxEncrypted = False , stActiveTxCryptState = Nothing , stActiveRxCryptState = Nothing , stPendingTxCryptState = Nothing , stPendingRxCryptState = Nothing , stActiveTxMacState = Nothing , stActiveRxMacState = Nothing , stPendingTxMacState = Nothing , stPendingRxMacState = Nothing , stActiveTxCipher = Nothing , stActiveRxCipher = Nothing , stPendingCipher = Nothing , stCompression = nullCompression , stRandomGen = StateRNG rng , stSecureRenegotiation = False , stClientVerifiedData = B.empty , stServerVerifiedData = B.empty , stExtensionNPN = False , stNegotiatedProtocol = Nothing , stServerNextProtocolSuggest = Nothing , stClientCertificateChain = Nothing } withTLSRNG :: StateRNG -> (forall g . CPRG g => g -> (a,g)) -> (a, StateRNG) withTLSRNG (StateRNG rng) f = let (a, rng') = f rng in (a, StateRNG rng') withCompression :: (Compression -> (Compression, a)) -> TLSSt a withCompression f = do compression <- stCompression <$> get let (nc, a) = f compression modify (\st -> st { stCompression = nc }) return a genTLSRandom :: (MonadState TLSState m, MonadError TLSError m) => Int -> m Bytes genTLSRandom n = do st <- get case withTLSRNG (stRandomGen st) (cprgGenerate n) of (bytes, rng') -> put (st { stRandomGen = rng' }) >> return bytes makeDigest :: MonadState TLSState m => Bool -> Header -> Bytes -> m Bytes makeDigest w hdr content = do st <- get let ver = stVersion st let cst = fromJust "crypt state" $ if w then stActiveTxCryptState st else stActiveRxCryptState st let ms = fromJust "mac state" $ if w then stActiveTxMacState st else stActiveRxMacState st let cipher = fromJust "cipher" $ if w then stActiveTxCipher st else stActiveRxCipher st let hashf = hashF $ cipherHash cipher let (macF, msg) = if ver < TLS10 then (macSSL hashf, B.concat [ encodeWord64 $ msSequence ms, encodeHeaderNoVer hdr, content ]) else (hmac hashf 64, B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ]) let digest = macF (cstMacSecret cst) msg let newms = ms { msSequence = (msSequence ms) + 1 } modify (\_ -> if w then st { stActiveTxMacState = Just newms } else st { stActiveRxMacState = Just newms }) return digest updateVerifiedData :: MonadState TLSState m => Bool -> Bytes -> m () updateVerifiedData sending bs = do cc <- isClientContext if cc /= sending then modify (\st -> st { stServerVerifiedData = bs }) else modify (\st -> st { stClientVerifiedData = bs }) finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello = True finishHandshakeTypeMaterial HandshakeType_ServerHello = True finishHandshakeTypeMaterial HandshakeType_Certificate = True finishHandshakeTypeMaterial HandshakeType_HelloRequest = False finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True finishHandshakeTypeMaterial HandshakeType_CertRequest = True finishHandshakeTypeMaterial HandshakeType_CertVerify = True finishHandshakeTypeMaterial HandshakeType_Finished = True finishHandshakeTypeMaterial HandshakeType_NPN = True finishHandshakeMaterial :: Handshake -> Bool finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake certVerifyHandshakeTypeMaterial :: HandshakeType -> Bool certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False certVerifyHandshakeTypeMaterial HandshakeType_ServerHelloDone = True certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False certVerifyHandshakeTypeMaterial HandshakeType_Finished = False certVerifyHandshakeTypeMaterial HandshakeType_NPN = False certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake switchTxEncryption, switchRxEncryption :: MonadState TLSState m => m () switchTxEncryption = modify (\st -> st { stTxEncrypted = True , stActiveTxMacState = stPendingTxMacState st , stActiveTxCryptState = stPendingTxCryptState st , stActiveTxCipher = stPendingCipher st }) switchRxEncryption = modify (\st -> st { stRxEncrypted = True , stActiveRxMacState = stPendingRxMacState st , stActiveRxCryptState = stPendingRxCryptState st , stActiveRxCipher = stPendingCipher st }) setServerRandom :: MonadState TLSState m => ServerRandom -> m () setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran }) setMasterSecret :: MonadState TLSState m => Bytes -> m () setMasterSecret masterSecret = do hasValidHandshake "master secret" updateHandshake "master secret" (\hst -> hst { hstMasterSecret = Just masterSecret } ) setKeyBlock return () setMasterSecretFromPre :: MonadState TLSState m => Bytes -> m () setMasterSecretFromPre premasterSecret = do hasValidHandshake "generate master secret" st <- get setMasterSecret $ genSecret st where genSecret st = let hst = fromJust "handshake" $ stHandshake st in generateMasterSecret (stVersion st) premasterSecret (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) getMasterSecret :: MonadState TLSState m => m (Maybe Bytes) getMasterSecret = gets (stHandshake >=> hstMasterSecret) setPublicKey :: MonadState TLSState m => PublicKey -> m () setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk }) setPrivateKey :: MonadState TLSState m => PrivateKey -> m () setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk }) setClientPublicKey :: MonadState TLSState m => PublicKey -> m () setClientPublicKey pk = updateHandshake "client publickey" (\hst -> hst { hstRSAClientPublicKey = Just pk }) setClientPrivateKey :: MonadState TLSState m => PrivateKey -> m () setClientPrivateKey pk = updateHandshake "client privatekey" (\hst -> hst { hstRSAClientPrivateKey = Just pk }) setCertReqSent :: MonadState TLSState m => Bool -> m () setCertReqSent b = updateHandshake "client cert req sent" (\hst -> hst { hstCertReqSent = b }) getCertReqSent :: MonadState TLSState m => m (Maybe Bool) getCertReqSent = gets (stHandshake >=> Just . hstCertReqSent) setClientCertSent :: MonadState TLSState m => Bool -> m () setClientCertSent b = updateHandshake "client cert sent" (\hst -> hst { hstClientCertSent = b }) getClientCertSent :: MonadState TLSState m => m (Maybe Bool) getClientCertSent = gets (stHandshake >=> Just . hstClientCertSent) setClientCertChain :: MonadState TLSState m => [X509] -> m () setClientCertChain b = updateHandshake "client certificate chain" (\hst -> hst { hstClientCertChain = Just b }) getClientCertChain :: MonadState TLSState m => m (Maybe [X509]) getClientCertChain = gets (stHandshake >=> hstClientCertChain) setClientCertRequest :: MonadState TLSState m => ClientCertRequestData -> m () setClientCertRequest d = updateHandshake "client cert data" (\hst -> hst { hstClientCertRequest = Just d }) getClientCertRequest :: MonadState TLSState m => m (Maybe ClientCertRequestData) getClientCertRequest = gets (stHandshake >=> hstClientCertRequest) getSessionData :: MonadState TLSState m => m (Maybe SessionData) getSessionData = get >>= \st -> return (stHandshake st >>= hstMasterSecret >>= wrapSessionData st) where wrapSessionData st masterSecret = do return $ SessionData { sessionVersion = stVersion st , sessionCipher = cipherID $ fromJust "cipher" $ stActiveTxCipher st , sessionSecret = masterSecret } setSession :: MonadState TLSState m => Session -> Bool -> m () setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming }) getSession :: MonadState TLSState m => m Session getSession = gets stSession isSessionResuming :: MonadState TLSState m => m Bool isSessionResuming = gets stSessionResuming needEmptyPacket :: MonadState TLSState m => m Bool needEmptyPacket = gets f where f st = (stVersion st <= TLS10) && stClientContext st && (maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stActiveTxCipher st)) setKeyBlock :: MonadState TLSState m => m () setKeyBlock = modify setPendingState where setPendingState st = st { stPendingTxCryptState = Just $ if cc then cstClient else cstServer , stPendingRxCryptState = Just $ if cc then cstServer else cstClient , stPendingTxMacState = Just $ if cc then msClient else msServer , stPendingRxMacState = Just $ if cc then msServer else msClient } where hst = fromJust "handshake" $ stHandshake st cc = stClientContext st cipher = fromJust "cipher" $ stPendingCipher st keyblockSize = cipherKeyBlockSize cipher bulk = cipherBulk cipher digestSize = hashSize $ cipherHash cipher keySize = bulkKeySize bulk ivSize = bulkIVSize bulk kb = generateKeyBlock (stVersion st) (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) (fromJust "master secret" $ hstMasterSecret hst) keyblockSize (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) cstClient = TLSCryptState { cstKey = cWriteKey , cstIV = cWriteIV , cstMacSecret = cMACSecret } cstServer = TLSCryptState { cstKey = sWriteKey , cstIV = sWriteIV , cstMacSecret = sMACSecret } msClient = TLSMacState { msSequence = 0 } msServer = TLSMacState { msSequence = 0 } setCipher :: MonadState TLSState m => Cipher -> m () setCipher cipher = modify (\st -> st { stPendingCipher = Just cipher }) setVersion :: MonadState TLSState m => Version -> m () setVersion ver = modify (\st -> st { stVersion = ver }) setSecureRenegotiation :: MonadState TLSState m => Bool -> m () setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b }) getSecureRenegotiation :: MonadState TLSState m => m Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionNPN :: MonadState TLSState m => Bool -> m () setExtensionNPN b = modify (\st -> st { stExtensionNPN = b }) getExtensionNPN :: MonadState TLSState m => m Bool getExtensionNPN = gets stExtensionNPN setNegotiatedProtocol :: MonadState TLSState m => B.ByteString -> m () setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s }) getNegotiatedProtocol :: MonadState TLSState m => m (Maybe B.ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol setServerNextProtocolSuggest :: MonadState TLSState m => [B.ByteString] -> m () setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps}) getServerNextProtocolSuggest :: MonadState TLSState m => m (Maybe [B.ByteString]) getServerNextProtocolSuggest = get >>= return . stServerNextProtocolSuggest setClientCertificateChain :: MonadState TLSState m => [X509] -> m () setClientCertificateChain s = modify (\st -> st { stClientCertificateChain = Just s }) getClientCertificateChain :: MonadState TLSState m => m (Maybe [X509]) getClientCertificateChain = gets stClientCertificateChain getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType) getCipherKeyExchangeType = gets (\st -> cipherKeyExchange <$> stPendingCipher st) getVerifiedData :: MonadState TLSState m => Bool -> m Bytes getVerifiedData client = gets (if client then stClientVerifiedData else stServerVerifiedData) isClientContext :: MonadState TLSState m => m Bool isClientContext = gets stClientContext -- create a new empty handshake state newEmptyHandshake :: Version -> ClientRandom -> HashCtx -> TLSHandshakeState newEmptyHandshake ver crand digestInit = TLSHandshakeState { hstClientVersion = ver , hstClientRandom = crand , hstServerRandom = Nothing , hstMasterSecret = Nothing , hstRSAPublicKey = Nothing , hstRSAPrivateKey = Nothing , hstRSAClientPublicKey = Nothing , hstRSAClientPrivateKey = Nothing , hstHandshakeDigest = digestInit , hstHandshakeMessages = [] , hstClientCertRequest = Nothing , hstClientCertSent = False , hstCertReqSent = False , hstClientCertChain = Nothing } startHandshakeClient :: MonadState TLSState m => Version -> ClientRandom -> m () startHandshakeClient ver crand = do -- FIXME check if handshake is already not null let initCtx = if ver < TLS12 then hashMD5SHA1 else hashSHA256 chs <- get >>= return . stHandshake when (isNothing chs) $ modify (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand initCtx }) hasValidHandshake :: MonadState TLSState m => String -> m () hasValidHandshake name = get >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ] updateHandshake :: MonadState TLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m () updateHandshake n f = do hasValidHandshake n modify (\st -> st { stHandshake = f <$> stHandshake st }) addHandshakeMessage :: MonadState TLSState m => Bytes -> m () addHandshakeMessage content = updateHandshake "add handshake message" $ \hs -> hs { hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: MonadState TLSState m => m [Bytes] getHandshakeMessages = do st <- get let hst = fromJust "handshake" $ stHandshake st return $ reverse $ hstHandshakeMessages hst updateHandshakeDigest :: MonadState TLSState m => Bytes -> m () updateHandshakeDigest content = updateHandshake "update digest" $ \hs -> hs { hstHandshakeDigest = hashUpdate (hstHandshakeDigest hs) content } getHandshakeDigest :: MonadState TLSState m => Bool -> m Bytes getHandshakeDigest client = do st <- get let hst = fromJust "handshake" $ stHandshake st let hashctx = hstHandshakeDigest hst let msecret = fromJust "master secret" $ hstMasterSecret hst return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret hashctx endHandshake :: MonadState TLSState m => m () endHandshake = modify (\st -> st { stHandshake = Nothing }) tls-1.1.5/Network/TLS/Receiving.hs0000644000000000000000000001667012213013270015051 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 -- module Network.TLS.Receiving (processHandshake, processPacket, processServerHello , verifyRSA) where import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Util import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Cipher import Network.TLS.Crypto import Network.TLS.Extension import Data.Certificate.X509 returnEither :: Either TLSError a -> TLSSt a returnEither (Left err) = throwError err returnEither (Right a) = return a processPacket :: Record Plaintext -> TLSSt Packet processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment switchRxEncryption return ChangeCipherSpec processPacket (Record ProtocolType_Handshake ver fragment) = do keyxchg <- getCipherKeyExchangeType npn <- getExtensionNPN let currentparams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg , cParamsSupportNPN = npn } handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment) hss <- forM handshakes $ \(ty, content) -> do case decodeHandshake currentparams ty content of Left err -> throwError err Right hs -> return hs return $ Handshake hss processPacket (Record ProtocolType_DeprecatedHandshake _ fragment) = case decodeDeprecatedHandshake $ fragmentGetBytes fragment of Left err -> throwError err Right hs -> return $ Handshake [hs] processHandshake :: Handshake -> TLSSt () processHandshake hs = do clientmode <- isClientContext case hs of ClientHello cver ran _ _ _ ex _ -> unless clientmode $ do mapM_ processClientExtension ex startHandshakeClient cver ran Certificates certs -> processCertificates clientmode certs ClientKeyXchg content -> unless clientmode $ do processClientKeyXchg content HsNextProtocolNegotiation selected_protocol -> unless clientmode $ do setNegotiatedProtocol selected_protocol Finished fdata -> processClientFinished fdata _ -> return () when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage $ encodeHandshake hs when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) where -- secure renegotiation processClientExtension (0xff01, content) = do v <- getVerifiedData True 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 () decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do st <- get ver <- stVersion <$> get rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get let cipher = if ver < TLS10 then econtent else B.drop 2 econtent let (mmsg,rng') = withTLSRNG (stRandomGen st) (\g -> kxDecrypt g rsapriv cipher) put (st { stRandomGen = rng' }) return mmsg verifyRSA :: HashDescr -> ByteString -> ByteString -> TLSSt Bool verifyRSA hsh econtent sign = do rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get return $ kxVerify rsapriv hsh econtent sign processServerHello :: Handshake -> TLSSt () processServerHello (ServerHello sver ran _ _ _ ex) = do -- FIXME notify the user to take action if the extension requested is missing -- secreneg <- getSecureRenegotiation -- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ... mapM_ processServerExtension ex setServerRandom ran setVersion sver where processServerExtension (0xff01, content) = do cv <- getVerifiedData True sv <- getVerifiedData False 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 () processServerHello _ = error "processServerHello called on wrong type" -- 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 :: ByteString -> TLSSt () processClientKeyXchg encryptedPremaster = do expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get random <- genTLSRandom 48 ePremaster <- decryptRSA encryptedPremaster case ePremaster of Left _ -> setMasterSecretFromPre random Right premaster -> case decodePreMasterSecret premaster of Left _ -> setMasterSecretFromPre random Right (ver, _) | ver /= expectedVer -> setMasterSecretFromPre random | otherwise -> setMasterSecretFromPre premaster processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do cc <- stClientContext <$> get expected <- getHandshakeDigest (not cc) when (expected /= fdata) $ do throwError $ Error_Protocol("bad record mac", True, BadRecordMac) updateVerifiedData False fdata return () processCertificates :: Bool -> [X509] -> TLSSt () processCertificates clientmode certs = do if null certs then when (clientmode) $ throwError $ Error_Protocol ("server certificate missing", True, HandshakeFailure) else do let (X509 mainCert _ _ _ _) = head certs case certPubKey mainCert of PubKeyRSA pubkey -> (if clientmode then setPublicKey else setClientPublicKey) (PubRSA pubkey) _ -> return () tls-1.1.5/Network/TLS/IO.hs0000644000000000000000000001155212213013270013437 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.IO -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.IO ( checkValid , ConnectionNotEstablished(..) , sendPacket , recvPacket ) where import Network.TLS.Context import Network.TLS.State (needEmptyPacket) import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.Sending import Network.TLS.Receiving import Data.Data import qualified Data.ByteString as B import Data.ByteString.Char8 () import Control.Monad.State import Control.Exception (throwIO, Exception()) import System.IO.Error (mkIOError, eofErrorType) data ConnectionNotEstablished = ConnectionNotEstablished deriving (Show,Eq,Typeable) instance Exception ConnectionNotEstablished checkValid :: MonadIO m => Context -> m () checkValid ctx = do established <- ctxEstablished ctx unless established $ liftIO $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing readExact :: MonadIO m => Context -> Int -> m Bytes readExact ctx sz = do hdrbs <- liftIO $ contextRecv ctx sz when (B.length hdrbs < sz) $ do setEOF ctx if B.null hdrbs then throwCore Error_EOF else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) return hdrbs recvRecord :: MonadIO m => Bool -- ^ flag to enable SSLv2 compat ClientHello reception -> Context -- ^ TLS context -> m (Either TLSError (Record Plaintext)) recvRecord compatSSLv2 ctx #ifdef SSLV2_COMPATIBLE | compatSSLv2 = do header <- readExact ctx 2 if B.head header < 0x80 then readExact ctx 3 >>= either (return . Left) recvLength . decodeHeader . B.append header else either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header #endif | otherwise = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader where recvLength header@(Header _ _ readlen) | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded | otherwise = readExact ctx (fromIntegral readlen) >>= makeRecord header #ifdef SSLV2_COMPATIBLE recvDeprecatedLength readlen | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do content <- readExact ctx (fromIntegral readlen) case decodeDeprecatedHeader readlen content of Left err -> return $ Left err Right header -> makeRecord header content #endif maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) makeRecord header content = do liftIO $ (loggingIORecv $ ctxLogging ctx) header content usingState 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 = do compatSSLv2 <- ctxHasSSLv2ClientHello ctx erecord <- recvRecord compatSSLv2 ctx case erecord of Left err -> return $ Left err Right record -> do pkt <- usingState ctx $ processPacket record case pkt of Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p _ -> return () 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 <- usingState_ ctx needEmptyPacket when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty liftIO $ (loggingPacketSent $ ctxLogging ctx) (show pkt) dataToSend <- usingState_ ctx $ writePacket pkt liftIO $ (loggingIOSent $ ctxLogging ctx) dataToSend liftIO $ contextSend ctx dataToSend where isNonNullAppData (AppData b) = not $ B.null b isNonNullAppData _ = False tls-1.1.5/Network/TLS/Cap.hs0000644000000000000000000000066412213013270013635 0ustar0000000000000000-- | -- Module : Network.TLS.Cap -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Cap ( hasHelloExtensions , hasExplicitBlockIV ) where import Network.TLS.Struct hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool hasHelloExtensions ver = ver >= SSL3 hasExplicitBlockIV ver = ver >= TLS11 tls-1.1.5/Network/TLS/Types.hs0000644000000000000000000000155712213013270014240 0ustar0000000000000000-- | -- Module : Network.TLS.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Types ( Version(..) , SessionID , SessionData(..) , CipherID , CompressionID ) where import Data.ByteString (ByteString) import Data.Word -- | Versions known to TLS -- -- SSL2 is just defined, but this version is and will not be supported. data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord) -- | A session ID type SessionID = ByteString -- | Session data to resume data SessionData = SessionData { sessionVersion :: Version , sessionCipher :: CipherID , sessionSecret :: ByteString } -- | Cipher identification type CipherID = Word16 -- | Compression identification type CompressionID = Word8 tls-1.1.5/Network/TLS/Record.hs0000644000000000000000000000164712213013270014352 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 , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext , recordToRaw , rawToRecord , recordToHeader , Plaintext , Compressed , Ciphertext , engageRecord , disengageRecord ) where import Network.TLS.Record.Types import Network.TLS.Record.Engage import Network.TLS.Record.Disengage tls-1.1.5/Network/TLS/Context.hs0000644000000000000000000004052012213013270014551 0ustar0000000000000000-- | -- Module : Network.TLS.Context -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE ExistentialQuantification, Rank2Types #-} -- only needed because of some GHC bug relative to insufficient polymorphic field {-# LANGUAGE RecordWildCards #-} module Network.TLS.Context ( -- * Context configuration Params(..) , RoleParams(..) , ClientParams(..) , ServerParams(..) , updateClientParams , updateServerParams , Logging(..) , SessionID , SessionData(..) , MaxFragmentEnum(..) , Measurement(..) , CertificateUsage(..) , CertificateRejectReason(..) , defaultLogging , defaultParamsClient , defaultParamsServer , withSessionManager , setSessionManager -- * Context object and accessor , Backend(..) , Context , ctxParams , ctxConnection , ctxEOF , ctxHasSSLv2ClientHello , ctxDisableSSLv2ClientHello , ctxEstablished , ctxLogging , setEOF , setEstablished , contextFlush , contextClose , contextSend , contextRecv , updateMeasure , withMeasure -- * deprecated types , TLSParams , TLSLogging , TLSCertificateUsage , TLSCertificateRejectReason , TLSCtx -- * deprecated values , defaultParams -- * New contexts , contextNew , contextNewOnHandle -- * Using context states , throwCore , usingState , usingState_ , getStateRNG ) where import Network.BSD (HostName) 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.Compression import Network.TLS.Crypto import Network.TLS.State import Network.TLS.Measurement import Data.Certificate.X509 import Data.List (intercalate) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Crypto.Random.API import Control.Concurrent.MVar import Control.Monad.State import Control.Exception (throwIO, Exception()) import Data.IORef import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) data Logging = Logging { loggingPacketSent :: String -> IO () , loggingPacketRecv :: String -> IO () , loggingIOSent :: B.ByteString -> IO () , loggingIORecv :: Header -> B.ByteString -> IO () } data ClientParams = ClientParams { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum , clientUseServerName :: Maybe HostName , clientWantSessionResume :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session. -- | 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 [(X509, Maybe PrivateKey)] } data ServerParams = ServerParams { serverWantClientCert :: Bool -- ^ request a certificate from client. -- | 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 :: [X509] -- | 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 :: [X509] -> IO CertificateUsage -- | This action is called when the client certificate -- cannot be verified. A 'Nothing' argument indicates a -- wrong signature, a 'Just e' message signals a crypto -- error. , onUnverifiedClientCert :: IO Bool , onCipherChoosing :: Version -> [Cipher] -> Cipher -- ^ callback on server to modify the cipher chosen. } data RoleParams = Client ClientParams | Server ServerParams data Params = forall s . SessionManager s => Params { pConnectVersion :: Version -- ^ version to use on client connection. , pAllowedVersions :: [Version] -- ^ allowed versions that we can use. , pCiphers :: [Cipher] -- ^ all ciphers supported ordered by priority. , pCompressions :: [Compression] -- ^ all compression supported ordered by priority. , pHashSignatures :: [HashAndSignatureAlgorithm] -- ^ All supported hash/signature algorithms pair for client certificate verification, ordered by decreasing priority. , pUseSecureRenegotiation :: Bool -- ^ notify that we want to use secure renegotation , pUseSession :: Bool -- ^ generate new session if specified , pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any. , pLogging :: Logging -- ^ callback for logging , onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake , onCertificatesRecv :: [X509] -> IO CertificateUsage -- ^ callback to verify received cert chain. , pSessionManager :: s , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- ^ suggested next protocols accoring to the next protocol negotiation extension. , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) , roleParams :: RoleParams } -- | Set a new session manager in a parameters structure. setSessionManager :: SessionManager s => s -> Params -> Params setSessionManager manager (Params {..}) = Params { pSessionManager = manager, .. } withSessionManager :: Params -> (forall s . SessionManager s => s -> a) -> a withSessionManager (Params { pSessionManager = man }) f = f man defaultLogging :: Logging defaultLogging = Logging { loggingPacketSent = (\_ -> return ()) , loggingPacketRecv = (\_ -> return ()) , loggingIOSent = (\_ -> return ()) , loggingIORecv = (\_ _ -> return ()) } defaultParamsClient :: Params defaultParamsClient = Params { pConnectVersion = TLS10 , pAllowedVersions = [TLS10,TLS11,TLS12] , pCiphers = [] , pCompressions = [nullCompression] , pHashSignatures = [ (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA256, SignatureRSA) , (Struct.HashSHA224, SignatureRSA) ] , pUseSecureRenegotiation = True , pUseSession = True , pCertificates = [] , pLogging = defaultLogging , onHandshake = (\_ -> return True) , onCertificatesRecv = (\_ -> return CertificateUsageAccept) , pSessionManager = NoSessionManager , onSuggestNextProtocols = return Nothing , onNPNServerSuggest = Nothing , roleParams = Client $ ClientParams { clientWantSessionResume = Nothing , clientUseMaxFragmentLength = Nothing , clientUseServerName = Nothing , onCertificateRequest = \ _ -> return [] } } defaultParamsServer :: Params defaultParamsServer = defaultParamsClient { roleParams = Server role } where role = ServerParams { serverWantClientCert = False , onCipherChoosing = \_ -> head , serverCACertificates = [] , onClientCertificate = \ _ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False } updateRoleParams :: (ClientParams -> ClientParams) -> (ServerParams -> ServerParams) -> Params -> Params updateRoleParams fc fs params = case roleParams params of Client c -> params { roleParams = Client (fc c) } Server s -> params { roleParams = Server (fs s) } updateClientParams :: (ClientParams -> ClientParams) -> Params -> Params updateClientParams f = updateRoleParams f id updateServerParams :: (ServerParams -> ServerParams) -> Params -> Params updateServerParams f = updateRoleParams id f defaultParams :: Params defaultParams = defaultParamsClient {-# DEPRECATED defaultParams "use defaultParamsClient" #-} instance Show Params where show p = "Params { " ++ (intercalate "," $ map (\(k,v) -> k ++ "=" ++ v) [ ("connectVersion", show $ pConnectVersion p) , ("allowedVersions", show $ pAllowedVersions p) , ("ciphers", show $ pCiphers p) , ("compressions", show $ pCompressions p) , ("certificates", show $ length $ pCertificates p) ]) ++ " }" -- | 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) -- | 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. } -- | A TLS Context keep tls specific state, parameters and backend information. data Context = Context { ctxConnection :: Backend -- ^ return the backend object associated with this context , ctxParams :: Params , 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. , 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. } -- deprecated types, setup as aliases for compatibility. type TLSParams = Params type TLSCtx = Context type TLSLogging = Logging type TLSCertificateUsage = CertificateUsage type TLSCertificateRejectReason = CertificateRejectReason updateMeasure :: MonadIO m => Context -> (Measurement -> Measurement) -> m () updateMeasure ctx f = liftIO $ do x <- readIORef (ctxMeasurement ctx) writeIORef (ctxMeasurement ctx) $! f x withMeasure :: MonadIO m => Context -> (Measurement -> IO a) -> m a withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f) contextFlush :: Context -> IO () contextFlush = backendFlush . ctxConnection contextClose :: Context -> IO () contextClose = backendClose . ctxConnection contextSend :: Context -> Bytes -> IO () contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b contextRecv :: Context -> Int -> IO Bytes contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz ctxEOF :: MonadIO m => Context -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx) ctxHasSSLv2ClientHello :: MonadIO m => Context -> m Bool ctxHasSSLv2ClientHello ctx = liftIO (readIORef $ ctxSSLv2ClientHello ctx) ctxDisableSSLv2ClientHello :: MonadIO m => Context -> m () ctxDisableSSLv2ClientHello ctx = liftIO (writeIORef (ctxSSLv2ClientHello ctx) False) setEOF :: MonadIO m => Context -> m () setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True ctxEstablished :: MonadIO m => Context -> m Bool ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx setEstablished :: MonadIO m => Context -> Bool -> m () setEstablished ctx v = liftIO $ writeIORef (ctxEstablished_ ctx) v ctxLogging :: Context -> Logging ctxLogging = pLogging . ctxParams -- | create a new context using the backend and parameters specified. contextNew :: (MonadIO m, CPRG rng) => Backend -- ^ Backend abstraction with specific method to interact with the connection type. -> Params -- ^ Parameters of the context. -> rng -- ^ Random number generator associated with this context. -> m Context contextNew backend params rng = liftIO $ do let clientContext = case roleParams params of Client {} -> True Server {} -> False let st = (newTLSState rng) { stClientContext = clientContext } 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 (not clientContext) return $ Context { ctxConnection = backend , ctxParams = params , ctxState = stvar , ctxMeasurement = stats , ctxEOF_ = eof , ctxEstablished_ = established , ctxSSLv2ClientHello = sslv2Compat } -- | create a new context on an handle. contextNewOnHandle :: (MonadIO m, CPRG rng) => Handle -- ^ Handle of the connection. -> Params -- ^ Parameters of the context. -> rng -- ^ Random number generator associated with this context. -> m Context contextNewOnHandle handle params st = liftIO (hSetBuffering handle NoBuffering) >> contextNew backend params st where backend = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle) throwCore :: (MonadIO m, Exception e) => e -> m a throwCore = liftIO . throwIO usingState :: MonadIO m => Context -> TLSSt a -> m (Either TLSError a) usingState ctx f = liftIO $ modifyMVar (ctxState ctx) $ \st -> let (a, newst) = runTLSState f st in newst `seq` return (newst, a) usingState_ :: MonadIO m => Context -> TLSSt a -> m a usingState_ ctx f = do ret <- usingState ctx f case ret of Left err -> throwCore err Right r -> return r getStateRNG :: MonadIO m => Context -> Int -> m Bytes getStateRNG ctx n = usingState_ ctx (genTLSRandom n) tls-1.1.5/Network/TLS/Internal.hs0000644000000000000000000000113212213013270014675 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 , sendPacket , recvPacket ) where import Network.TLS.Struct import Network.TLS.Packet import Network.TLS.Receiving import Network.TLS.Sending import Network.TLS.Core (sendPacket, recvPacket) tls-1.1.5/Network/TLS/Handshake.hs0000644000000000000000000000264112213013270015015 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake ( handshake , handshakeServerWith , handshakeClient , HandshakeFailed(..) ) where import Network.TLS.Context import Network.TLS.Struct import Network.TLS.IO import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State import Control.Exception (fromException) import qualified Control.Exception as E -- | 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 = do let handshakeF = case roleParams $ ctxParams ctx of Server sparams -> handshakeServer sparams Client cparams -> handshakeClient cparams liftIO $ handleException $ handshakeF ctx where handleException f = E.catch f $ \exception -> do let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception setEstablished ctx False sendPacket ctx (errorToAlert tlserror) handshakeFailed tlserror tls-1.1.5/Network/TLS/Util.hs0000644000000000000000000000432112213013270014041 0ustar0000000000000000module Network.TLS.Util ( sub , takelast , partition3 , partition6 , fromJust , and' , (&&!) , bytesEq ) where import Data.List (foldl') import Network.TLS.Struct (Bytes) import qualified Data.ByteString as B sub :: Bytes -> Int -> Int -> Maybe Bytes sub b offset len | B.length b < offset + len = Nothing | otherwise = Just $ B.take len $ snd $ B.splitAt offset b takelast :: Int -> Bytes -> Maybe Bytes takelast i b | B.length b >= i = sub b (B.length b - i) i | otherwise = Nothing partition3 :: Bytes -> (Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes) partition3 bytes (d1,d2,d3) | any (< 0) l = Nothing | sum l /= B.length bytes = Nothing | otherwise = Just (p1,p2,p3) where l = [d1,d2,d3] (p1, r1) = B.splitAt d1 bytes (p2, r2) = B.splitAt d2 r1 (p3, _) = B.splitAt d3 r2 partition6 :: Bytes -> (Int,Int,Int,Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes, Bytes) partition6 bytes (d1,d2,d3,d4,d5,d6) = if B.length bytes < s then Nothing else Just (p1,p2,p3,p4,p5,p6) where s = sum [d1,d2,d3,d4,d5,d6] (p1, r1) = B.splitAt d1 bytes (p2, r2) = B.splitAt d2 r1 (p3, r3) = B.splitAt d3 r2 (p4, r4) = B.splitAt d4 r3 (p5, r5) = B.splitAt d5 r4 (p6, _) = B.splitAt d6 r5 fromJust :: String -> Maybe a -> a fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck fromJust _ (Just x) = x -- | This is a strict version of and and' :: [Bool] -> Bool and' l = foldl' (&&!) True l -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool True &&! True = True True &&! False = False False &&! True = False False &&! False = False -- | verify that 2 bytestrings are equals. -- it's a non lazy version, that will compare every bytes. -- arguments with different length will bail out early bytesEq :: Bytes -> Bytes -> Bool bytesEq b1 b2 | B.length b1 /= B.length b2 = False | otherwise = and' $ B.zipWith (==) b1 b2 tls-1.1.5/Network/TLS/Extension.hs0000644000000000000000000001257212213013270015107 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 -- all extensions ID supported , extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_SecureRenegotiation , extensionID_NextProtocolNegotiation -- all implemented extensions , ServerNameType(..) , ServerName(..) , MaxFragmentLength(..) , MaxFragmentEnum(..) , SecureRenegotiation(..) , NextProtocolNegotiation(..) ) where import Control.Applicative ((<$>)) import Control.Monad import Data.Word import Data.Maybe (fromMaybe) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Network.TLS.Struct (ExtensionID) import Network.TLS.Wire import Network.BSD (HostName) extensionID_ServerName, extensionID_MaxFragmentLength , extensionID_SecureRenegotiation , extensionID_NextProtocolNegotiation :: ExtensionID extensionID_ServerName = 0x0 extensionID_MaxFragmentLength = 0x1 extensionID_SecureRenegotiation = 0xff01 extensionID_NextProtocolNegotiation = 0x3374 -- | all supported extensions by the implementation supportedExtensions :: [ExtensionID] supportedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_SecureRenegotiation , extensionID_NextProtocolNegotiation ] -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID extensionDecode :: Bool -> ByteString -> Maybe a extensionEncode :: a -> ByteString -- | Server Name extension including the name type and the associated name. -- the associated name decoding is dependant of its name type. -- name type = 0 : hostname data ServerName = ServerName [ServerNameType] deriving (Show,Eq) data ServerNameType = ServerNameHostName HostName | ServerNameOther (Word8, ByteString) deriving (Show,Eq) instance Extension ServerName where extensionID _ = extensionID_ServerName extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque extensionDecode _ = runGetMaybe (getWord16 >>= \len -> getList (fromIntegral len) getServerName >>= return . ServerName) where getServerName = do ty <- getWord8 sname <- getOpaque16 return (1+2+B.length sname, case ty of 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion _ -> ServerNameOther (ty, sname)) -- | Max fragment extension with length from 512 bytes to 4096 bytes data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum deriving (Show,Eq) data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096 deriving (Show,Eq) instance Extension MaxFragmentLength where extensionID _ = extensionID_MaxFragmentLength extensionEncode (MaxFragmentLength e) = B.singleton $ marshallSize e where marshallSize MaxFragment512 = 1 marshallSize MaxFragment1024 = 2 marshallSize MaxFragment2048 = 3 marshallSize MaxFragment4096 = 4 extensionDecode _ = runGetMaybe (MaxFragmentLength . unmarshallSize <$> getWord8) where unmarshallSize 1 = MaxFragment512 unmarshallSize 2 = MaxFragment1024 unmarshallSize 3 = MaxFragment2048 unmarshallSize 4 = MaxFragment4096 unmarshallSize n = error ("unknown max fragment size " ++ show n) -- | Secure Renegotiation data SecureRenegotiation = SecureRenegotiation ByteString (Maybe ByteString) deriving (Show,Eq) instance Extension SecureRenegotiation where extensionID _ = extensionID_SecureRenegotiation extensionEncode (SecureRenegotiation cvd svd) = runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty svd) extensionDecode isServerHello = runGetMaybe getSecureReneg where getSecureReneg = do opaque <- getOpaque8 if isServerHello then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque in return $ SecureRenegotiation cvd (Just svd) else return $ SecureRenegotiation opaque Nothing -- | Next Protocol Negotiation data NextProtocolNegotiation = NextProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension NextProtocolNegotiation where extensionID _ = extensionID_NextProtocolNegotiation extensionEncode (NextProtocolNegotiation bytes) = runPut $ mapM_ putOpaque8 bytes extensionDecode _ = runGetMaybe (NextProtocolNegotiation <$> getNPN) where getNPN = do avail <- remaining case avail of 0 -> return [] _ -> do liftM2 (:) getOpaque8 getNPN tls-1.1.5/Network/TLS/Measurement.hs0000644000000000000000000000267712213013270015425 0ustar0000000000000000-- | -- Module : Network.TLS.Measurement -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Measurement ( Measurement(..) , newMeasurement , addBytesReceived , addBytesSent , resetBytesCounters , incrementNbHandshakes ) where import Data.Word -- | record some data about this connection. data Measurement = Measurement { nbHandshakes :: !Word32 -- ^ number of handshakes on this context , bytesReceived :: !Word32 -- ^ bytes received since last handshake , bytesSent :: !Word32 -- ^ bytes sent since last handshake } deriving (Show,Eq) newMeasurement :: Measurement newMeasurement = Measurement { nbHandshakes = 0 , bytesReceived = 0 , bytesSent = 0 } addBytesReceived :: Int -> Measurement -> Measurement addBytesReceived sz measure = measure { bytesReceived = bytesReceived measure + fromIntegral sz } addBytesSent :: Int -> Measurement -> Measurement addBytesSent sz measure = measure { bytesSent = bytesSent measure + fromIntegral sz } resetBytesCounters :: Measurement -> Measurement resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 } incrementNbHandshakes :: Measurement -> Measurement incrementNbHandshakes measure = measure { nbHandshakes = nbHandshakes measure + 1 } tls-1.1.5/Network/TLS/Packet.hs0000644000000000000000000005341012213013270014336 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 , decodeHandshakes , decodeHandshake , decodeDeprecatedHandshake , encodeHandshake , encodeHandshakes , encodeHandshakeHeader , encodeHandshakeContent -- * marshall functions for change cipher spec message , decodeChangeCipherSpec , encodeChangeCipherSpec , decodePreMasterSecret , encodePreMasterSecret -- * generate things for packet content , generateMasterSecret , generateKeyBlock , generateClientFinished , generateServerFinished , generateCertificateVerify_SSL ) where import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap import Data.Either (partitionEithers) import Data.Maybe (fromJust) import Data.Word import Data.Bits ((.|.)) import Control.Applicative ((<$>)) import Control.Monad import Data.Certificate.X509 (decodeCertificate, encodeCertificate, X509, encodeDN, decodeDN) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version , cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension } deriving (Show,Eq) {- marshall helpers -} getVersion :: Get Version getVersion = do major <- getWord8 minor <- getWord8 case verOfNum (major, minor) of Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) Just v -> return v putVersion :: Version -> Put putVersion ver = putWord8 major >> putWord8 minor where (major, minor) = numericalVer ver getHeaderType :: Get ProtocolType getHeaderType = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid header type: " ++ show ty) Just t -> return t putHeaderType :: ProtocolType -> Put putHeaderType = putWord8 . valOfType getHandshakeType :: Get HandshakeType getHandshakeType = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid handshake type: " ++ show ty) Just t -> return t {- - decode and encode headers -} decodeHeader :: ByteString -> Either TLSError Header decodeHeader = runGetErr "header" $ liftM3 Header getHeaderType getVersion getWord16 decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16 decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16 decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header decodeDeprecatedHeader size = runGetErr "deprecatedheader" $ do 1 <- getWord8 version <- getVersion return $ Header ProtocolType_DeprecatedHandshake version size encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len) {- FIXME check len <= 2^14 -} encodeHeaderNoVer :: Header -> ByteString encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len) {- FIXME check len <= 2^14 -} {- - decode and encode ALERT -} decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do al <- getWord8 ad <- getWord8 case (valToType al, valToType ad) of (Just a, Just d) -> return (a, d) (Nothing, _) -> fail "cannot decode alert level" (_, Nothing) -> fail "cannot decode alert description" decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)] decodeAlerts = runGetErr "alerts" $ loop where loop = do r <- remaining if r == 0 then return [] else liftM2 (:) decodeAlert loop encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString encodeAlerts l = runPut $ mapM_ encodeAlert l where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad) {- decode and encode HANDSHAKE -} decodeHandshakeHeader :: Get (HandshakeType, Bytes) decodeHandshakeHeader = do ty <- getHandshakeType content <- getOpaque24 return (ty, content) decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)] decodeHandshakes b = runGetErr "handshakes" getAll b where getAll = do x <- decodeHandshakeHeader empty <- isEmpty if empty then return [x] else liftM ((:) x) getAll decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr "handshake" $ 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 HandshakeType_Finished -> decodeFinished HandshakeType_NPN -> do unless (cParamsSupportNPN cp) $ fail "unsupported handshake type" decodeNextProtocolNegotiation decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where getDeprecated = do 1 <- getWord8 ver <- getVersion cipherSpecLen <- fromEnum <$> getWord16 sessionIdLen <- fromEnum <$> getWord16 challengeLen <- fromEnum <$> getWord16 ciphers <- getCipherSpec cipherSpecLen session <- getSessionId sessionIdLen random <- getChallenge challengeLen let compressions = [0] return $ ClientHello ver random session ciphers compressions [] (Just b) getCipherSpec len | len < 3 = return [] getCipherSpec len = do [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) getSessionId 0 = return $ Session Nothing getSessionId len = Session . Just <$> getBytes len getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest decodeClientHello :: Get Handshake decodeClientHello = do ver <- getVersion random <- getClientRandom32 session <- getSession ciphers <- getWords16 compressions <- getWords8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fmap fromIntegral getWord16 >>= getExtensions else return [] return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake decodeServerHello = do ver <- getVersion random <- getServerRandom32 session <- getSession cipherid <- getWord16 compressionid <- getWord8 r <- remaining exts <- if hasHelloExtensions ver && r > 0 then fmap fromIntegral getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone decodeCertificates :: Get Handshake decodeCertificates = do certsRaw <- getWord24 >>= \len -> getList (fromIntegral len) getCertRaw let (badCerts, certs) = partitionEithers $ map (decodeCertificate . L.fromChunks . (:[])) certsRaw if not $ null badCerts then fail ("error certificate parsing: " ++ show badCerts) else return $ Certificates certs where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) decodeFinished :: Get Handshake decodeFinished = Finished <$> (remaining >>= getBytes) decodeNextProtocolNegotiation :: Get Handshake decodeNextProtocolNegotiation = do opaque <- getOpaque8 _ <- getOpaque8 -- ignore padding return $ HsNextProtocolNegotiation opaque getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- fromJust . valToType <$> getWord8 s <- fromJust . valToType <$> getWord8 return (h,s) decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 sigHashAlgs <- if cParamsVersion cp >= TLS12 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) else return Nothing dNameLen <- getWord16 -- FIXME: Decide whether to remove this check completely or to make it an option. -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size" dNames <- getList (fromIntegral dNameLen) getDName return $ CertRequest certTypes sigHashAlgs dNames where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) getDName = do dName <- getOpaque16 when (B.length dName == 0) $ fail "certrequest: invalid DN length" dn <- decodeDName dName return (2 + B.length dName, dn) decodeDName d = case decodeDN (L.fromChunks [d]) of Left err -> fail ("certrequest: " ++ show err) Right s -> return s decodeCertVerify :: CurrentParams -> Get Handshake decodeCertVerify cp = do mbHashSig <- if cParamsVersion cp >= TLS12 then Just <$> getSignatureHashAlgorithm else return Nothing bs <- getOpaque16 return $ CertVerify mbHashSig (CertVerifyData bs) decodeClientKeyXchg :: Get Handshake decodeClientKeyXchg = ClientKeyXchg <$> (remaining >>= getBytes) os2ip :: ByteString -> Integer os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0 decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = do p <- getOpaque16 g <- getOpaque16 y <- getOpaque16 return $ ServerDHParams { dh_p = os2ip p, dh_g = os2ip g, dh_Ys = os2ip y } decodeServerKeyXchg_RSA :: Get ServerRSAParams decodeServerKeyXchg_RSA = do modulus <- getOpaque16 expo <- getOpaque16 return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } decodeServerKeyXchg :: CurrentParams -> Get Handshake decodeServerKeyXchg cp = ServerKeyXchg <$> case cParamsKeyXchgType cp of CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH CipherKeyExchange_DHE_RSA -> do dhparams <- decodeServerKeyXchg_DH signature <- getOpaque16 return $ SKX_DHE_RSA dhparams (B.unpack signature) CipherKeyExchange_DHE_DSS -> do dhparams <- decodeServerKeyXchg_DH signature <- getOpaque16 return $ SKX_DHE_DSS dhparams (B.unpack signature) _ -> do bs <- remaining >>= getBytes return $ SKX_Unknown bs 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 certs) = putOpaque24 (runPut $ mapM_ putCert certs) encodeHandshakeContent (ClientKeyXchg content) = do putBytes content encodeHandshakeContent (ServerKeyXchg _) = do -- FIXME return () 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 $ 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 mbHashSig (CertVerifyData c)) = do -- TLS 1.2 prepends the hash and signature algorithms to the -- signature. case mbHashSig of Nothing -> return () Just (h, s) -> putWord16 $ (fromIntegral $ valOfType h) * 256 + (fromIntegral $ valOfType s) putWord16 (fromIntegral $ B.length c) putBytes c encodeHandshakeContent (Finished opaque) = putBytes opaque encodeHandshakeContent (HsNextProtocolNegotiation protocol) = do putOpaque8 protocol putOpaque8 $ B.replicate paddingLen 0 where paddingLen = 32 - ((B.length protocol + 2) `mod` 32) {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get Bytes getRandom32 = getBytes 32 getServerRandom32 :: Get ServerRandom getServerRandom32 = ServerRandom <$> getRandom32 getClientRandom32 :: Get ClientRandom getClientRandom32 = ClientRandom <$> getRandom32 putRandom32 :: Bytes -> Put putRandom32 = putBytes putClientRandom32 :: ClientRandom -> Put putClientRandom32 (ClientRandom r) = putRandom32 r putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r getSession :: Get Session getSession = do len8 <- getWord8 case fromIntegral len8 of 0 -> return $ Session Nothing len -> Session . Just <$> getBytes len putSession :: Session -> Put putSession (Session Nothing) = putWord8 0 putSession (Session (Just s)) = putOpaque8 s putCert :: X509 -> Put putCert cert = putOpaque24 (B.concat $ L.toChunks $ encodeCertificate cert) 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 $ (extty, extdata) : extxs putExtension :: ExtensionRaw -> Put putExtension (ty, l) = putWord16 ty >> putOpaque16 l putExtensions :: [ExtensionRaw] -> Put putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) {- - decode and encode ALERT -} decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do x <- getWord8 when (x /= 1) (fail "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) -- rsa pre master secret decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes) decodePreMasterSecret = runGetErr "pre-master-secret" $ do liftM2 (,) getVersion (getBytes 46) encodePreMasterSecret :: Version -> Bytes -> Bytes encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes) {- - generate things for packet content -} type PRF = Bytes -> Bytes -> Int -> Bytes generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = B.concat $ map (computeMD5) ["A","BB","CCC"] where computeMD5 label = MD5.hash $ B.concat [ premasterSecret, computeSHA1 label ] computeSHA1 label = SHA1.hash $ B.concat [ label, premasterSecret, c, s ] generateMasterSecret_TLS :: PRF -> Bytes -> ClientRandom -> ServerRandom -> Bytes generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) = prf premasterSecret seed 48 where seed = B.concat [ "master secret", c, s ] generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes generateMasterSecret SSL2 = generateMasterSecret_SSL generateMasterSecret SSL3 = generateMasterSecret_SSL generateMasterSecret TLS10 = generateMasterSecret_TLS prf_MD5SHA1 generateMasterSecret TLS11 = generateMasterSecret_TLS prf_MD5SHA1 generateMasterSecret TLS12 = generateMasterSecret_TLS prf_SHA256 generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ] generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] computeMD5 label = MD5.hash $ B.concat [ mastersecret, computeSHA1 label ] computeSHA1 label = SHA1.hash $ B.concat [ label, mastersecret, s, c ] generateKeyBlock :: Version -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes generateKeyBlock SSL2 = generateKeyBlock_SSL generateKeyBlock SSL3 = generateKeyBlock_SSL generateKeyBlock TLS10 = generateKeyBlock_TLS prf_MD5SHA1 generateKeyBlock TLS11 = generateKeyBlock_TLS prf_MD5SHA1 generateKeyBlock TLS12 = generateKeyBlock_TLS prf_SHA256 generateFinished_TLS :: PRF -> Bytes -> Bytes -> HashCtx -> Bytes generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 where seed = B.concat [ label, hashFinal hashctx ] generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> Bytes generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] where md5hash = MD5.hash $ B.concat [ mastersecret, pad2, md5left ] sha1hash = SHA1.hash $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1) $ foldl hashUpdate hashctx [sender,mastersecret] (md5left,sha1left) = B.splitAt 16 lefthash pad2 = B.replicate 48 0x5c pad1 = B.replicate 48 0x36 generateClientFinished :: Version -> Bytes -> HashCtx -> Bytes generateClientFinished ver | ver < TLS10 = generateFinished_SSL "CLNT" | ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "client finished" | otherwise = generateFinished_TLS prf_SHA256 "client finished" generateServerFinished :: Version -> Bytes -> HashCtx -> Bytes generateServerFinished ver | ver < TLS10 = generateFinished_SSL "SRVR" | ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "server finished" | otherwise = generateFinished_TLS prf_SHA256 "server finished" generateCertificateVerify_SSL :: Bytes -> HashCtx -> Bytes generateCertificateVerify_SSL = generateFinished_SSL "" tls-1.1.5/Network/TLS/Session.hs0000644000000000000000000000166612213013270014560 0ustar0000000000000000-- | -- Module : Network.TLS.Session -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Session ( SessionManager(..) , NoSessionManager(..) ) where import Network.TLS.Types -- | A session manager class SessionManager a where -- | used on server side to decide whether to resume a client session sessionResume :: a -> SessionID -> IO (Maybe SessionData) -- | used when a session is established. sessionEstablish :: a -> SessionID -> SessionData -> IO () -- | used when a session is invalidated sessionInvalidate :: a -> SessionID -> IO () data NoSessionManager = NoSessionManager instance SessionManager NoSessionManager where sessionResume _ _ = return Nothing sessionEstablish _ _ _ = return () sessionInvalidate _ _ = return () tls-1.1.5/Network/TLS/Cipher.hs0000644000000000000000000000611212213013270014336 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Network.TLS.Cipher -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Cipher ( BulkFunctions(..) , CipherKeyExchangeType(..) , Bulk(..) , Hash(..) , Cipher(..) , CipherID , cipherKeyBlockSize , Key , IV , cipherExchangeNeedMoreData ) where import Network.TLS.Types (CipherID) import Network.TLS.Struct (Version(..)) import qualified Data.ByteString as B -- FIXME convert to newtype type Key = B.ByteString type IV = B.ByteString data BulkFunctions = BulkBlockF (Key -> IV -> B.ByteString -> B.ByteString) (Key -> IV -> B.ByteString -> B.ByteString) | BulkStreamF (Key -> IV) (IV -> B.ByteString -> (B.ByteString, IV)) (IV -> B.ByteString -> (B.ByteString, IV)) 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 , bulkBlockSize :: Int , bulkF :: BulkFunctions } data Hash = Hash { hashName :: String , hashSize :: Int , hashF :: B.ByteString -> B.ByteString } -- | Cipher algorithm data Cipher = Cipher { cipherID :: CipherID , cipherName :: String , cipherHash :: Hash , cipherBulk :: Bulk , cipherKeyExchange :: CipherKeyExchangeType , cipherMinVer :: Maybe Version } cipherKeyBlockSize :: Cipher -> Int cipherKeyBlockSize cipher = 2 * (hashSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk) where bulk = cipherBulk cipher 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.1.5/Network/TLS/MAC.hs0000644000000000000000000000550512213013270013531 0ustar0000000000000000-- | -- Module : Network.TLS.MAC -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.MAC ( hmacMD5 , hmacSHA1 , hmacSHA256 , macSSL , hmac , prf_MD5 , prf_SHA1 , prf_SHA256 , prf_MD5SHA1 ) where import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString as B import Data.ByteString (ByteString) import Data.Bits (xor) type HMAC = ByteString -> ByteString -> ByteString macSSL :: (ByteString -> ByteString) -> HMAC macSSL f secret msg = f $! B.concat [ secret, B.replicate padlen 0x5c, f $! B.concat [ secret, B.replicate padlen 0x36, msg ] ] where -- get the type of algorithm out of the digest length by using the hash fct. padlen = if (B.length $ f B.empty) == 16 then 48 else 40 hmac :: (ByteString -> ByteString) -> Int -> HMAC hmac f bl secret msg = f $! B.append opad (f $! B.append ipad msg) where opad = B.map (xor 0x5c) k' ipad = B.map (xor 0x36) k' 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 hmacMD5 :: HMAC hmacMD5 secret msg = hmac MD5.hash 64 secret msg hmacSHA1 :: HMAC hmacSHA1 secret msg = hmac SHA1.hash 64 secret msg hmacSHA256 :: HMAC hmacSHA256 secret msg = hmac SHA256.hash 64 secret msg 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 hmacSHA1 secret seed seed len prf_MD5 :: ByteString -> ByteString -> Int -> ByteString prf_MD5 secret seed len = B.concat $ hmacIter hmacMD5 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 hmacSHA256 secret seed seed len tls-1.1.5/Network/TLS/Crypto.hs0000644000000000000000000001002112213013270014376 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Crypto ( HashCtx(..) , hashInit , hashUpdate , hashUpdateSSL , hashFinal -- * constructor , hashMD5SHA1 , hashSHA256 -- * key exchange generic interface , PublicKey(..) , PrivateKey(..) , HashDescr(..) , kxEncrypt , kxDecrypt , kxSign , kxVerify , KxError(..) ) where import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as B import Data.ByteString (ByteString) import Crypto.PubKey.HashDescr import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import Crypto.Random.API data PublicKey = PubRSA RSA.PublicKey data PrivateKey = PrivRSA RSA.PrivateKey instance Show PublicKey where show (_) = "PublicKey(..)" instance Show PrivateKey where show (_) = "privateKey(..)" data KxError = RSAError RSA.Error deriving (Show) class HashCtxC a where hashCName :: a -> String hashCInit :: a -> a hashCUpdate :: a -> B.ByteString -> a hashCUpdateSSL :: a -> (B.ByteString,B.ByteString) -> a hashCFinal :: a -> B.ByteString data HashCtx = forall h . HashCtxC h => HashCtx h instance Show HashCtx where show (HashCtx c) = hashCName c {- MD5 & SHA1 joined -} data HashMD5SHA1 = HashMD5SHA1 SHA1.Ctx MD5.Ctx instance HashCtxC HashMD5SHA1 where hashCName _ = "MD5-SHA1" hashCInit _ = HashMD5SHA1 SHA1.init MD5.init hashCUpdate (HashMD5SHA1 sha1ctx md5ctx) b = HashMD5SHA1 (SHA1.update sha1ctx b) (MD5.update md5ctx b) hashCUpdateSSL (HashMD5SHA1 sha1ctx md5ctx) (b1,b2) = HashMD5SHA1 (SHA1.update sha1ctx b2) (MD5.update md5ctx b1) hashCFinal (HashMD5SHA1 sha1ctx md5ctx) = B.concat [MD5.finalize md5ctx, SHA1.finalize sha1ctx] data HashSHA256 = HashSHA256 SHA256.Ctx instance HashCtxC HashSHA256 where hashCName _ = "SHA256" hashCInit _ = HashSHA256 SHA256.init hashCUpdate (HashSHA256 ctx) b = HashSHA256 (SHA256.update ctx b) hashCUpdateSSL _ _ = undefined hashCFinal (HashSHA256 ctx) = SHA256.finalize ctx -- functions to use the hidden class. hashInit :: HashCtx -> HashCtx hashInit (HashCtx h) = HashCtx $ hashCInit h hashUpdate :: HashCtx -> B.ByteString -> HashCtx hashUpdate (HashCtx h) b = HashCtx $ hashCUpdate h b hashUpdateSSL :: HashCtx -> (B.ByteString,B.ByteString) -> HashCtx hashUpdateSSL (HashCtx h) bs = HashCtx $ hashCUpdateSSL h bs hashFinal :: HashCtx -> B.ByteString hashFinal (HashCtx h) = hashCFinal h -- real hash constructors hashMD5SHA1, hashSHA256 :: HashCtx hashMD5SHA1 = HashCtx (HashMD5SHA1 SHA1.init MD5.init) hashSHA256 = HashCtx (HashSHA256 SHA256.init) {- key exchange methods encrypt and decrypt for each supported algorithm -} generalizeRSAWithRNG :: CPRG g => (Either RSA.Error a, g) -> (Either KxError a, g) generalizeRSAWithRNG (Left e, g) = (Left (RSAError e), g) generalizeRSAWithRNG (Right x, g) = (Right x, g) kxEncrypt :: CPRG g => g -> PublicKey -> ByteString -> (Either KxError ByteString, g) kxEncrypt g (PubRSA pk) b = generalizeRSAWithRNG $ RSA.encrypt g pk b kxDecrypt :: CPRG g => g -> PrivateKey -> ByteString -> (Either KxError ByteString, g) kxDecrypt g (PrivRSA pk) b = generalizeRSAWithRNG $ RSA.decryptSafer g pk b -- Verify that the signature matches the given message, using the -- public key. -- kxVerify :: PublicKey -> HashDescr -> ByteString -> ByteString -> Bool kxVerify (PubRSA pk) hashDescr msg sign = RSA.verify hashDescr pk msg sign -- Sign the given message using the private key. -- kxSign :: CPRG g => g -> PrivateKey -> HashDescr -> ByteString -> (Either KxError ByteString, g) kxSign g (PrivRSA pk) hashDescr msg = generalizeRSAWithRNG $ RSA.signSafer g hashDescr pk msg tls-1.1.5/Network/TLS/Wire.hs0000644000000000000000000000715412213013270014041 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 , runGet , runGetErr , runGetMaybe , remaining , getWord8 , getWords8 , getWord16 , getWords16 , getWord24 , getBytes , getOpaque8 , getOpaque16 , getOpaque24 , getList , processBytes , isEmpty , Put , runPut , putWord8 , putWords8 , putWord16 , putWords16 , putWord24 , putBytes , putOpaque8 , putOpaque16 , putOpaque24 , encodeWord16 , encodeWord64 ) where import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put import Control.Applicative ((<$>)) import Control.Monad.Error import qualified Data.ByteString as B import Data.Word import Data.Bits import Network.TLS.Struct runGet :: String -> Get a -> Bytes -> Either String a runGet lbl f = G.runGet (label lbl f) runGetErr :: String -> Get a -> Bytes -> Either TLSError a runGetErr lbl f = either (Left . Error_Packet_Parsing) Right . runGet lbl f runGetMaybe :: Get a -> Bytes -> Maybe a runGetMaybe f = either (const Nothing) Just . runGet "" f getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8 getWord16 :: Get Word16 getWord16 = getWord16be getWords16 :: Get [Word16] getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16 getWord24 :: Get Int getWord24 = do a <- fromIntegral <$> getWord8 b <- fromIntegral <$> getWord8 c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c getOpaque8 :: Get Bytes getOpaque8 = getWord8 >>= getBytes . fromIntegral getOpaque16 :: Get Bytes getOpaque16 = getWord16 >>= getBytes . fromIntegral getOpaque24 :: Get Bytes getOpaque24 = getWord24 >>= getBytes getList :: Int -> (Get (Int, a)) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen) where getElements len | len < 0 = error "list consumed too much data. should never happen with isolate." | len == 0 = return [] | otherwise = getElement >>= \(elementLen, a) -> liftM ((:) a) (getElements (len - elementLen)) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f putWords8 :: [Word8] -> Put putWords8 l = do putWord8 $ fromIntegral (length l) mapM_ putWord8 l putWord16 :: Word16 -> Put putWord16 = putWord16be putWords16 :: [Word16] -> Put putWords16 l = do putWord16 $ 2 * (fromIntegral $ length l) mapM_ putWord16 l putWord24 :: Int -> Put putWord24 i = do let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff) mapM_ putWord8 [a,b,c] putBytes :: Bytes -> Put putBytes = putByteString putOpaque8 :: Bytes -> Put putOpaque8 b = putWord8 (fromIntegral $ B.length b) >> putBytes b putOpaque16 :: Bytes -> Put putOpaque16 b = putWord16 (fromIntegral $ B.length b) >> putBytes b putOpaque24 :: Bytes -> Put putOpaque24 b = putWord24 (B.length b) >> putBytes b encodeWord16 :: Word16 -> Bytes encodeWord16 = runPut . putWord16 encodeWord64 :: Word64 -> Bytes encodeWord64 = runPut . putWord64be tls-1.1.5/Network/TLS/Record/0000755000000000000000000000000012213013270014006 5ustar0000000000000000tls-1.1.5/Network/TLS/Record/Disengage.hs0000644000000000000000000001206712213013270016236 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. -- module Network.TLS.Record.Disengage ( disengageRecord ) where import Control.Monad.State import Control.Monad.Error import Network.TLS.Struct import Network.TLS.Cap import Network.TLS.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Util import Data.ByteString (ByteString) import qualified Data.ByteString as B disengageRecord :: Record Ciphertext -> TLSSt (Record Plaintext) disengageRecord = decryptRecord >=> uncompressRecord uncompressRecord :: Record Compressed -> TLSSt (Record Plaintext) uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes -> withCompression $ compressionInflate bytes decryptRecord :: Record Ciphertext -> TLSSt (Record Compressed) decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do st <- get if stRxEncrypted st then get >>= decryptData record e else return e getCipherData :: Record a -> CipherData -> TLSSt 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 False 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 <- gets stVersion let b = B.length pad - 1 return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) unless (macValid &&! paddingValid) $ do throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) return $ cipherDataContent cdata decryptData :: Record Ciphertext -> Bytes -> TLSState -> TLSSt Bytes decryptData record econtent st = decryptOf (bulkF bulk) where cipher = fromJust "cipher" $ stActiveRxCipher st bulk = cipherBulk cipher cst = fromJust "rx crypt state" $ stActiveRxCryptState st macSize = hashSize $ cipherHash cipher writekey = cstKey cst blockSize = bulkBlockSize bulk econtentLen = B.length econtent explicitIV = hasExplicitBlockIV $ stVersion st sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") decryptOf :: BulkFunctions -> TLSSt Bytes decryptOf (BulkBlockF _ decryptF) = do let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize 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 newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent' put $ st { stActiveRxCryptState = Just $ cst { cstIV = newiv } } let content' = decryptF writekey iv econtent' 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 (BulkStreamF initF _ decryptF) = do when (econtentLen < macSize) $ sanityCheckError let iv = cstIV cst let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent {- update Ctx -} let contentlen = B.length content' - macSize (content, mac) <- get2 content' (contentlen, macSize) put $ st { stActiveRxCryptState = Just $ cst { cstIV = newiv } } getCipherData record $ CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Nothing } 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.1.5/Network/TLS/Record/Engage.hs0000644000000000000000000000711412213013270015533 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. -- module Network.TLS.Record.Engage ( engageRecord ) where import Control.Monad.State import Network.TLS.Cap import Network.TLS.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Util import Data.ByteString (ByteString) import qualified Data.ByteString as B engageRecord :: Record Plaintext -> TLSSt (Record Ciphertext) engageRecord = compressRecord >=> encryptRecord compressRecord :: Record Plaintext -> TLSSt (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 packet -} encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext) encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do st <- get if stTxEncrypted st then encryptContent record bytes else return bytes encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString encryptContent record content = do digest <- makeDigest True (recordToHeader record) content encryptData $ B.concat [content, digest] encryptData :: ByteString -> TLSSt ByteString encryptData content = do st <- get let cipher = fromJust "cipher" $ stActiveTxCipher st let bulk = cipherBulk cipher let cst = fromJust "tx crypt state" $ stActiveTxCryptState st let writekey = cstKey cst case bulkF bulk of BulkBlockF encrypt _ -> do 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 -- before TLS 1.1, the block cipher IV is made of the residual of the previous block. iv <- if hasExplicitBlockIV $ stVersion st then genTLSRandom (bulkIVSize bulk) else return $ cstIV cst let e = encrypt writekey iv (B.concat [ content, padding ]) if hasExplicitBlockIV $ stVersion st then return $ B.concat [iv,e] else do let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e put $ st { stActiveTxCryptState = Just $ cst { cstIV = newiv } } return e BulkStreamF initF encryptF _ -> do let iv = cstIV cst let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content put $ st { stActiveTxCryptState = Just $ cst { cstIV = newiv } } return e tls-1.1.5/Network/TLS/Record/Types.hs0000644000000000000000000000662412213013270015456 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 , fragmentPlaintext , fragmentCiphertext , fragmentGetBytes , Plaintext , Compressed , Ciphertext -- * manipulate record , onRecordFragment , fragmentCompress , fragmentCipher , fragmentUncipher , fragmentUncompress -- * serialize record , rawToRecord , recordToRaw , recordToHeader ) where import Network.TLS.Struct import Network.TLS.State import qualified Data.ByteString as B import Control.Applicative ((<$>)) -- | Represent a TLS record. data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) newtype Fragment a = Fragment Bytes deriving (Show,Eq) data Plaintext data Compressed data Ciphertext fragmentPlaintext :: Bytes -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes fragmentCiphertext :: Bytes -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes fragmentGetBytes :: Fragment a -> Bytes fragmentGetBytes (Fragment bytes) = bytes onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b -- | turn a plaintext record into a compressed record using the compression function supplied fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed) fragmentCompress f = fragmentMap f -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed) fragmentUncipher f = fragmentMap f -- | turn a compressed fragment into a plaintext fragment using the decompression function supplied fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, Bytes) recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes) -- | turn a header and a fragment into a record rawToRecord :: Header -> Fragment a -> Record a rawToRecord (Header pt ver _) fragment = Record pt ver fragment -- | turn a record into a header recordToHeader :: Record a -> Header recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes) tls-1.1.5/Network/TLS/Handshake/0000755000000000000000000000000012213013270014456 5ustar0000000000000000tls-1.1.5/Network/TLS/Handshake/Client.hs0000644000000000000000000003370212213013270016235 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Client -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Client ( handshakeClient ) where import Network.TLS.Crypto import Network.TLS.Context import Network.TLS.Struct import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Packet import Network.TLS.Extension import Network.TLS.IO import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Sending import Network.TLS.Receiving import Network.TLS.Measurement import Network.TLS.Wire (encodeWord16) import Data.Maybe import Data.List (find) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.Certificate.X509(X509, x509Cert, certPubKey, PubKey(PubKeyRSA)) import Control.Applicative ((<$>)) import Control.Monad.State import Control.Exception (SomeException) import qualified Control.Exception as E import Network.TLS.Handshake.Common import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: MonadIO m => ClientParams -> Context -> m () handshakeClient cparams ctx = do updateMeasure ctx incrementNbHandshakes sentExtensions <- sendClientHello recvServerHello sentExtensions sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish ctx True else do sendClientData cparams ctx sendChangeCipherAndFinish ctx True recvChangeCipherAndFinish ctx handshakeTerminate ctx where params = ctxParams ctx allowedvers = pAllowedVersions params ciphers = pCiphers params compressions = pCompressions params getExtensions = sequence [sniExtension,secureReneg,npnExtention] >>= return . catMaybes toExtensionRaw :: Extension e => e -> ExtensionRaw toExtensionRaw ext = (extensionID ext, extensionEncode ext) secureReneg = if pUseSecureRenegotiation params then usingState_ ctx (getVerifiedData True) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing else return Nothing npnExtention = if isJust $ onNPNServerSuggest params then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] else return Nothing sniExtension = return ((\h -> toExtensionRaw $ ServerName [(ServerNameHostName h)]) <$> clientUseServerName cparams) sendClientHello = do crand <- getStateRNG ctx 32 >>= return . ClientRandom let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams extensions <- getExtensions usingState_ ctx (startHandshakeClient (pConnectVersion params) crand) sendPacket ctx $ Handshake [ ClientHello (pConnectVersion params) crand clientSession (map cipherID ciphers) (map compressionID compressions) extensions Nothing ] return $ map fst extensions 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") recvServerHello sentExts = runRecvState ctx (RecvStateHandshake $ onServerHello sentExts) onServerHello :: MonadIO m => [ExtensionID] -> Handshake -> m (RecvState m) onServerHello sentExts sh@(ServerHello rver _ serverSession cipher _ exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) allowedvers of Nothing -> throwCore $ Error_Protocol ("version " ++ show rver ++ "is not supported", True, ProtocolVersion) Just _ -> usingState_ ctx $ setVersion rver case find ((==) cipher . cipherID) ciphers of Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) Just c -> usingState_ ctx $ setCipher c -- intersect sent extensions in client and the received extensions from server. -- if server returns extensions that we didn't request, fail. when (not $ null $ filter (not . flip elem sentExts . fst) 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 $ setSession serverSession (isJust resumingSession) usingState_ ctx $ processServerHello sh case extensionDecode False `fmap` (lookup extensionID_NextProtocolNegotiation exts) of Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do setExtensionNPN True setServerNextProtocolSuggest protos _ -> return () case resumingSession of Nothing -> return $ RecvStateHandshake processCertificate Just sessionData -> do usingState_ ctx (setMasterSecret $ sessionSecret sessionData) return $ RecvStateNext expectChangeCipher onServerHello _ p = unexpected (show p) (Just "server hello") processCertificate :: MonadIO m => Handshake -> m (RecvState m) processCertificate (Certificates certs) = do usage <- liftIO $ E.catch (onCertificatesRecv params $ certs) rejectOnException case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason return $ RecvStateHandshake processServerKeyExchange processCertificate p = processServerKeyExchange p processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m) processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest processServerKeyExchange p = processCertificateRequest p processCertificateRequest :: MonadIO m => Handshake -> m (RecvState m) processCertificateRequest (CertRequest cTypes sigAlgs dNames) = do -- When the server requests a client -- certificate, we simply store the -- information for later. -- usingState_ ctx $ setClientCertRequest (cTypes, sigAlgs, dNames) return $ RecvStateHandshake processServerHelloDone processCertificateRequest p = processServerHelloDone p processServerHelloDone ServerHelloDone = return RecvStateDone processServerHelloDone p = unexpected (show p) (Just "server hello data") -- | send client Data after receiving all server data (hello/certificates/key). -- -- -> [certificate] -- -> client key exchange -- -> [cert verify] sendClientData :: MonadIO m => ClientParams -> Context -> m () 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 <- usingState_ ctx getClientCertRequest case certRequested of Nothing -> return () Just req -> do certChain <- liftIO $ onCertificateRequest cparams req `E.catch` throwMiscErrorOnException "certificate request callback failed" case certChain of (_, Nothing) : _ -> throwCore $ Error_Misc "no private key available" (cert, Just pk) : _ -> do case certPubKey $ x509Cert cert of PubKeyRSA _ -> return () _ -> throwCore $ Error_Protocol ("no supported certificate type", True, HandshakeFailure) usingState_ ctx $ setClientPrivateKey pk _ -> return () usingState_ ctx $ setClientCertSent (not $ null certChain) sendPacket ctx $ Handshake [Certificates $ map fst certChain] sendClientKeyXchg = do encryptedPreMaster <- usingState_ ctx $ do xver <- stVersion <$> get prerand <- genTLSRandom 46 let premaster = encodePreMasterSecret xver prerand setMasterSecretFromPre premaster -- 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 premaster let extra = if xver < TLS10 then B.empty else encodeWord16 $ fromIntegral $ B.length e return $ extra `B.append` e sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster] -- 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 $ stVersion <$> get -- Only send a certificate verify message when we -- have sent a non-empty list of certificates. -- certSent <- usingState_ ctx $ getClientCertSent case certSent of Just True -> do -- Fetch all handshake messages up to now. msgs <- usingState_ ctx $ B.concat <$> getHandshakeMessages case usedVersion of SSL3 -> do Just masterSecret <- usingState_ ctx $ getMasterSecret let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs) hsh = HashDescr id id sigDig <- usingState_ ctx $ signRSA hsh digest sendPacket ctx $ Handshake [CertVerify Nothing (CertVerifyData sigDig)] x | x == TLS10 || x == TLS11 -> do let hashf bs = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs) hsh = HashDescr hashf id sigDig <- usingState_ ctx $ signRSA hsh msgs sendPacket ctx $ Handshake [CertVerify Nothing (CertVerifyData sigDig)] _ -> do Just (_, Just hashSigs, _) <- usingState_ ctx $ getClientCertRequest let suppHashSigs = pHashSignatures $ ctxParams ctx hashSigs' = filter (\ a -> a `elem` hashSigs) suppHashSigs liftIO $ putStrLn $ " supported hash sig algorithms: " ++ show hashSigs' when (null hashSigs') $ do throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure) let hashSig = head hashSigs' hsh <- getHashAndASN1 hashSig sigDig <- usingState_ ctx $ signRSA hsh msgs sendPacket ctx $ Handshake [CertVerify (Just hashSig) (CertVerifyData sigDig)] _ -> return () throwMiscErrorOnException :: MonadIO m => String -> SomeException -> m a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e tls-1.1.5/Network/TLS/Handshake/Common.hs0000644000000000000000000001203712213013270016245 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Network.TLS.Handshake.Common ( HandshakeFailed(..) , handshakeFailed , errorToAlert , unexpected , newSession , handshakeTerminate -- * sending packets , sendChangeCipherAndFinish -- * receiving packets , recvChangeCipherAndFinish , RecvState(..) , runRecvState , recvPacketHandshake ) where import Network.TLS.Context import Network.TLS.Session import Network.TLS.Struct import Network.TLS.IO import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Receiving import Network.TLS.Measurement import Data.Maybe import Data.Data import Data.ByteString.Char8 () import Control.Monad.State import Control.Exception (throwIO, Exception()) data HandshakeFailed = HandshakeFailed TLSError deriving (Show,Eq,Typeable) instance Exception HandshakeFailed 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 :: MonadIO m => String -> Maybe [Char] -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: MonadIO m => Context -> m Session newSession ctx | pUseSession $ ctxParams ctx = getStateRNG ctx 32 >>= return . Session . Just | otherwise = return $ Session Nothing -- | when a new handshake is done, wrap up & clean up. handshakeTerminate :: MonadIO m => Context -> m () 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 <- usingState_ ctx getSessionData withSessionManager (ctxParams ctx) (\s -> liftIO $ sessionEstablish s sessionId (fromJust sessionData)) _ -> return () -- forget all handshake data now and reset bytes counters. usingState_ ctx endHandshake updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. setEstablished ctx True return () sendChangeCipherAndFinish :: MonadIO m => Context -> Bool -> m () sendChangeCipherAndFinish ctx isClient = do sendPacket ctx ChangeCipherSpec when isClient $ do suggest <- usingState_ ctx $ getServerNextProtocolSuggest case (onNPNServerSuggest (ctxParams ctx), suggest) of -- client offered, server picked up. send NPN handshake. (Just io, Just protos) -> do proto <- liftIO $ io protos sendPacket ctx (Handshake [HsNextProtocolNegotiation proto]) usingState_ ctx $ setNegotiatedProtocol proto -- client offered, server didn't pick up. do nothing. (Just _, Nothing) -> return () -- client didn't offer. do nothing. (Nothing, _) -> return () liftIO $ contextFlush ctx cf <- usingState_ ctx $ getHandshakeDigest isClient sendPacket ctx (Handshake [Finished cf]) liftIO $ contextFlush ctx recvChangeCipherAndFinish :: MonadIO m => Context -> m () 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 :: MonadIO m => Context -> m [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 runRecvState :: MonadIO m => Context -> RecvState m -> m () runRecvState _ (RecvStateDone) = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx where loop :: MonadIO m => RecvState m -> [Handshake] -> m (RecvState m) loop recvState [] = return recvState loop (RecvStateHandshake f) (x:xs) = do nstate <- f x usingState_ ctx $ processHandshake x loop nstate xs loop _ _ = unexpected "spurious handshake" Nothing tls-1.1.5/Network/TLS/Handshake/Certificate.hs0000644000000000000000000000234112213013270017234 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 import Network.TLS.Struct import Control.Monad.State import Control.Exception (SomeException) -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a certificateRejected CertificateRejectRevoked = throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked) certificateRejected CertificateRejectExpired = throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired) certificateRejected CertificateRejectUnknownCA = throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa) certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) rejectOnException :: SomeException -> IO TLSCertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e tls-1.1.5/Network/TLS/Handshake/Signature.hs0000644000000000000000000000162412213013270016756 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Signature -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Signature ( getHashAndASN1 ) where import Crypto.PubKey.HashDescr import Network.TLS.Context import Network.TLS.Struct import Control.Monad.State getHashAndASN1 :: MonadIO m => (HashAlgorithm, SignatureAlgorithm) -> m HashDescr getHashAndASN1 hashSig = do case hashSig of (HashSHA1, SignatureRSA) -> return hashDescrSHA1 (HashSHA224, SignatureRSA) -> return hashDescrSHA224 (HashSHA256, SignatureRSA) -> return hashDescrSHA256 (HashSHA384, SignatureRSA) -> return hashDescrSHA384 (HashSHA512, SignatureRSA) -> return hashDescrSHA512 _ -> throwCore $ Error_Misc "unsupported hash/sig algorithm" tls-1.1.5/Network/TLS/Handshake/Server.hs0000644000000000000000000003732512213013270016272 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Server ( handshakeServer , handshakeServerWith ) where import Network.TLS.Crypto import Network.TLS.Context import Network.TLS.Session import Network.TLS.Struct import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Packet import Network.TLS.Extension import Network.TLS.IO import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Receiving import Network.TLS.Measurement import Data.Maybe import Data.List (intersect) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.Certificate.X509(X509, certSubjectDN, x509Cert) import Control.Applicative ((<$>)) import Control.Monad.State import qualified Control.Exception as E import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Common import Network.TLS.Handshake.Certificate -- 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 = do hss <- recvPacketHandshake ctx case hss of [ch] -> handshakeServerWith sparams ctx ch _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss) -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter. -- This is useful when the client hello has been already poped from the recv layer to inspect the packet. -- -- When the function returns, a new handshake has been succesfully negociated. -- On any error, a HandshakeFailed exception is raised. -- -- handshake protocol (<- receiving, -> sending, [] optional): -- (no session) (session resumption) -- <- client hello <- client hello -- -> server hello -> server hello -- -> [certificate] -- -> [server key xchg] -- -> [cert request] -- -> hello done -- <- [certificate] -- <- client key xchg -- <- [cert verify] -- <- change cipher -> change cipher -- <- [NPN] -- <- finish -> finish -- -> change cipher <- change cipher -- -> finish <- finish -- handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m () handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx) unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes -- Handle Client hello usingState_ ctx $ processHandshake clientHello when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) when (not $ elem ver (pAllowedVersions params)) $ throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) when (commonCipherIDs == []) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) when (null commonCompressions) $ throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) usingState_ ctx $ modify (\st -> st { stVersion = ver , stPendingCipher = Just usedCipher , stCompression = usedCompression }) resumeSessionData <- case clientSession of (Session (Just clientSessionId)) -> withSessionManager params (\s -> liftIO $ sessionResume s clientSessionId) (Session Nothing) -> return Nothing case resumeSessionData of Nothing -> do handshakeSendServerData liftIO $ contextFlush ctx -- Receive client info until client Finished. recvClientData sparams ctx sendChangeCipherAndFinish ctx False Just sessionData -> do usingState_ ctx (setSession clientSession True) serverhello <- makeServerHello clientSession sendPacket ctx $ Handshake [serverhello] usingState_ ctx $ setMasterSecret $ sessionSecret sessionData sendChangeCipherAndFinish ctx False recvChangeCipherAndFinish ctx handshakeTerminate ctx where params = ctxParams ctx commonCipherIDs = intersect ciphers (map cipherID $ pCiphers params) commonCiphers = filter (flip elem commonCipherIDs . cipherID) (pCiphers params) usedCipher = (onCipherChoosing sparams) ver commonCiphers commonCompressions = compressionIntersectID (pCompressions params) compressions usedCompression = head commonCompressions srvCerts = map fst $ pCertificates params privKeys = map snd $ pCertificates params needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher clientRequestedNPN = isJust $ lookup extensionID_NextProtocolNegotiation exts --- -- When the client sends a certificate, check whether -- it is acceptable for the application. -- --- makeServerHello session = do srand <- getStateRNG ctx 32 >>= return . ServerRandom case privKeys of (Just privkey : _) -> usingState_ 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 True svf <- getVerifiedData False return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ (0xff01, vf) ] else return [] nextProtocols <- if clientRequestedNPN then liftIO $ onSuggestNextProtocols params else return Nothing npnExt <- case nextProtocols of Just protos -> do usingState_ ctx $ do setExtensionNPN True setServerNextProtocolSuggest protos return [ ( extensionID_NextProtocolNegotiation , extensionEncode $ NextProtocolNegotiation protos) ] Nothing -> return [] let extensions = secRengExt ++ npnExt usingState_ ctx (setVersion ver >> setServerRandom srand) return $ ServerHello ver 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 sendPacket ctx $ Handshake [ serverhello, Certificates srvCerts ] when needKeyXchg $ do let skg = SKX_RSA Nothing sendPacket ctx (Handshake [ServerKeyXchg skg]) -- 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 $ stVersion <$> get let certTypes = [ CertificateType_RSA_Sign ] hashSigs = if usedVersion < TLS12 then Nothing else Just (pHashSignatures $ ctxParams ctx) creq = CertRequest certTypes hashSigs (map extractCAname $ serverCACertificates sparams) usingState_ ctx $ setCertReqSent True sendPacket ctx (Handshake [creq]) -- Send HelloDone sendPacket ctx (Handshake [ServerHelloDone]) extractCAname :: X509 -> DistinguishedName extractCAname cert = certSubjectDN (x509Cert cert) handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello" -- | receive Client data in handshake until the Finished handshake. -- -- <- [certificate] -- <- client key xchg -- <- [cert verify] -- <- change cipher -- <- [NPN] -- <- finish -- recvClientData :: MonadIO m => ServerParams -> Context -> m () recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) where processClientCertificate (Certificates certs) = do -- Call application callback to see whether the -- certificate chain is acceptable. -- usage <- liftIO $ E.catch (onClientCertificate sparams certs) rejectOnException case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason -- Remember cert chain for later use. -- usingState_ 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 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 mbHashSig (CertVerifyData bs))]) = do usingState_ ctx $ processHandshake hs chain <- usingState_ ctx $ getClientCertChain case chain of Just (_:_) -> return () _ -> throwCore $ Error_Protocol ("change cipher message expected", True, UnexpectedMessage) -- Fetch all handshake messages up to now. msgs <- usingState_ ctx $ B.concat <$> getHandshakeMessages usedVersion <- usingState_ ctx $ stVersion <$> get (signature, hsh) <- case usedVersion of SSL3 -> do Just masterSecret <- usingState_ ctx $ getMasterSecret let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs) hsh = HashDescr id id return (digest, hsh) x | x == TLS10 || x == TLS11 -> do let hashf bs' = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs') hsh = HashDescr hashf id return (msgs,hsh) _ -> do let Just sentHashSig = mbHashSig hsh <- getHashAndASN1 sentHashSig return (msgs,hsh) -- Verify the signature. verif <- usingState_ ctx $ verifyRSA hsh signature bs case verif of True -> do -- When verification succeeds, commit the -- client certificate chain to the context. -- Just certs <- usingState_ ctx $ getClientCertChain usingState_ ctx $ setClientCertificateChain certs return () False -> do -- Either verification failed because of an -- invalid format (with an error message), or -- the signature is wrong. In either case, -- ask the application if it wants to -- proceed, we will do that. res <- liftIO $ onUnverifiedClientCert 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 <- usingState_ ctx $ getClientCertChain usingState_ ctx $ setClientCertificateChain certs else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) return $ RecvStateNext expectChangeCipher processCertificateVerify p = do chain <- usingState_ ctx $ getClientCertChain case chain of Just (_:_) -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage) _ -> return () expectChangeCipher p expectChangeCipher ChangeCipherSpec = do npn <- usingState_ ctx getExtensionNPN return $ RecvStateHandshake $ if npn then expectNPN else expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectNPN (HsNextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegotiation") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") tls-1.1.5/Tests/0000755000000000000000000000000012213013270011577 5ustar0000000000000000tls-1.1.5/Tests/PubKey.hs0000644000000000000000000000166412213013270013341 0ustar0000000000000000module PubKey ( arbitraryRSAPair , globalRSAPair , getGlobalRSAPair ) where import Test.QuickCheck import Crypto.Random (createTestEntropyPool) import qualified Crypto.Random.AESCtr as RNG import qualified Crypto.PubKey.RSA as RSA import qualified Data.ByteString as B import Control.Concurrent.MVar import System.IO.Unsafe arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) arbitraryRSAPair = do rng <- (RNG.make . createTestEntropyPool . B.pack) `fmap` vector 64 arbitraryRSAPairWithRNG rng arbitraryRSAPairWithRNG rng = return $ fst $ RSA.generate rng 128 0x10001 {-# NOINLINE globalRSAPair #-} globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey) globalRSAPair = unsafePerformIO (RNG.makeSystem >>= arbitraryRSAPairWithRNG >>= newMVar) {-# NOINLINE getGlobalRSAPair #-} getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) tls-1.1.5/Tests/Tests.hs0000644000000000000000000003046212213013270013242 0ustar0000000000000000{-# LANGUAGE CPP #-} import Test.QuickCheck import Test.QuickCheck.Monadic import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Certificate import PipeChan import Connection import Data.Maybe import Data.Word 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.Internal import Control.Applicative import Control.Concurrent import Control.Exception (throw, SomeException) import qualified Control.Exception as E import Control.Monad import Data.IORef 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 ] #if MIN_VERSION_QuickCheck(2,3,0) #else instance Arbitrary Word8 where arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int) instance Arbitrary Word16 where arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int) #endif 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 CertVerifyData where arbitrary = do liftM CertVerifyData (genByteString 128) 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 (resize 2 $ listOf $ arbitraryX509) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg <$> genByteString 48 --, liftM ServerKeyXchg , liftM3 CertRequest arbitrary (return Nothing) (return []) , liftM2 CertVerify (return Nothing) 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 = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA, cParamsSupportNPN = True } 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 () establish_data_pipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe _ <- (runPipe pipe) startQueue <- newChan resultQueue <- newChan (cCtx, sCtx) <- newPairContext pipe params _ <- forkIO $ E.catch (tlsServer sCtx resultQueue) (printAndRaise "server") _ <- forkIO $ E.catch (tlsClient startQueue cCtx) (printAndRaise "client") return (startQueue, resultQueue) where printAndRaise :: String -> SomeException -> IO () printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do params <- pick arbitraryPairParams (startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient) {- the test involves writing data on one side of the data "pipe" and - then checking we received them on the other side of the data "pipe" -} d <- B.pack <$> pick (someWords8 256) run $ writeChan startQueue d dres <- run $ readChan resultQueue d `assertEq` dres return () where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () prop_handshake_npn_initiate :: PropertyM IO () prop_handshake_npn_initiate = do (clientParam,serverParam) <- pick arbitraryPairParams let clientParam' = clientParam { onNPNServerSuggest = Just $ \protos -> return (head protos) } serverParam' = serverParam { onSuggestNextProtocols = return $ Just [C8.pack "spdy/2", C8.pack "http/1.1"] } params' = (clientParam',serverParam') (startQueue, resultQueue) <- run (establish_data_pipe params' tlsServer tlsClient) {- the test involves writing data on one side of the data "pipe" and - then checking we received them on the other side of the data "pipe" -} d <- B.pack <$> pick (someWords8 256) run $ writeChan startQueue d dres <- run $ readChan resultQueue d `assertEq` dres return () where tlsServer ctx queue = do handshake ctx proto <- getNegotiatedProtocol ctx Just (C8.pack "spdy/2") `assertEq` proto d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx proto <- getNegotiatedProtocol ctx Just (C8.pack "spdy/2") `assertEq` proto d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () prop_handshake_renegociation :: PropertyM IO () prop_handshake_renegociation = do params <- pick arbitraryPairParams (startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient) {- the test involves writing data on one side of the data "pipe" and - then checking we received them on the other side of the data "pipe" -} d <- B.pack <$> pick (someWords8 256) run $ writeChan startQueue d dres <- run $ readChan resultQueue d `assertEq` dres return () where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () -- | simple session manager to store one session id and session data for a single thread. -- a Real concurrent session manager would use an MVar and have multiples items. data OneSessionManager = OneSessionManager (IORef (Maybe (SessionID, SessionData))) instance SessionManager OneSessionManager where sessionInvalidate _ _ = return () sessionEstablish (OneSessionManager ref) myId dat = writeIORef ref $ Just (myId, dat) sessionResume (OneSessionManager ref) myId = readIORef ref >>= maybeResume where maybeResume Nothing = return Nothing maybeResume (Just (sid, sdata)) = return (if sid == myId then Just sdata else Nothing) prop_handshake_session_resumption :: PropertyM IO () prop_handshake_session_resumption = do sessionRef <- run $ newIORef Nothing let sessionManager = OneSessionManager sessionRef plainParams <- pick arbitraryPairParams let params = setPairParamsSessionManager sessionManager plainParams -- establish a session. (s1, r1) <- run (establish_data_pipe params tlsServer tlsClient) d <- B.pack <$> pick (someWords8 256) run $ writeChan s1 d dres <- run $ readChan r1 d `assertEq` dres -- and resume sessionParams <- run $ readIORef sessionRef assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params -- resume (startQueue, resultQueue) <- run (establish_data_pipe params2 tlsServer tlsClient) {- the test involves writing data on one side of the data "pipe" and - then checking we received them on the other side of the data "pipe" -} d2 <- B.pack <$> pick (someWords8 256) run $ writeChan startQueue d2 dres2 <- run $ readChan resultQueue d2 `assertEq` dres2 return () where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx writeChan queue d return () tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d]) bye ctx return () assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) main :: IO () main = defaultMain [ tests_marshalling , 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 ] -- high level tests between a client and server with fake ciphers. tests_handshake = testGroup "Handshakes" [ testProperty "setup" (monadicIO prop_pipe_work) , testProperty "initiate" (monadicIO prop_handshake_initiate) , testProperty "initiate with npn" (monadicIO prop_handshake_npn_initiate) , testProperty "renegociation" (monadicIO prop_handshake_renegociation) , testProperty "resumption" (monadicIO prop_handshake_session_resumption) ] tls-1.1.5/Tests/PipeChan.hs0000644000000000000000000000366012213013270013627 0ustar0000000000000000-- create a similar concept than a unix pipe. module PipeChan ( PipeChan(..) , newPipe , runPipe , readPipeA , readPipeB , writePipeA , writePipeB ) where import Control.Applicative import Control.Concurrent.Chan import Control.Concurrent import Control.Monad (forever) import Data.ByteString (ByteString) import Data.IORef import qualified Data.ByteString as B -- | represent a unidirectional pipe with a buffered read channel and a write channel data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) newUniPipeChan = UniPipeChan <$> newChan <*> newChan runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w getReadUniPipe (UniPipeChan r _) = r getWriteUniPipe (UniPipeChan _ w) = w -- | Represent a bidirectional pipe with 2 nodes A and B data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s -- helper to read buffered data. readBuffered buf chan sz = do left <- readIORef buf if B.length left >= sz then do let (ret, nleft) = B.splitAt sz left writeIORef buf nleft return ret else do let newSize = (sz - B.length left) newData <- readChan chan writeIORef buf newData remain <- readBuffered buf chan newSize return (left `B.append` remain) tls-1.1.5/Tests/Certificate.hs0000644000000000000000000000361412213013270014361 0ustar0000000000000000module Certificate ( arbitraryX509 , arbitraryX509WithPublicKey ) where import Test.QuickCheck import qualified Data.Certificate.X509 as X509 import qualified Data.Certificate.X509.Cert as Cert import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (secondsToDiffTime) import PubKey arbitraryDN = return $ Cert.DistinguishedName [] arbitraryTime = do year <- choose (1951, 2050) month <- choose (1, 12) day <- choose (1, 30) hour <- choose (0, 23) minute <- choose (0, 59) second <- choose (0, 59) z <- arbitrary return (fromGregorian year month day , secondsToDiffTime (hour * 3600 + minute * 60 + second) , z) maxSerial = 16777216 arbitraryX509Cert pubKey = do version <- choose (1,3) serial <- choose (0,maxSerial) issuerdn <- arbitraryDN subjectdn <- arbitraryDN time1 <- arbitraryTime time2 <- arbitraryTime let sigalg = X509.SignatureALG X509.HashMD5 X509.PubKeyALG_RSA return $ Cert.Certificate { X509.certVersion = version , X509.certSerial = serial , X509.certSignatureAlg = sigalg , X509.certIssuerDN = issuerdn , X509.certSubjectDN = subjectdn , X509.certValidity = (time1, time2) , X509.certPubKey = pubKey , X509.certExtensions = Nothing } arbitraryX509WithPublicKey pubKey = do cert <- arbitraryX509Cert (X509.PubKeyRSA pubKey) sig <- resize 40 $ listOf1 arbitrary let sigalg = X509.SignatureALG X509.HashMD5 X509.PubKeyALG_RSA return (X509.X509 cert Nothing Nothing sigalg sig) arbitraryX509 = do let pubKey = fst $ getGlobalRSAPair arbitraryX509WithPublicKey pubKey tls-1.1.5/Tests/Connection.hs0000644000000000000000000001040412213013270014231 0ustar0000000000000000module Connection ( newPairContext , arbitraryPairParams , setPairParamsSessionManager , setPairParamsSessionResuming ) where import Test.QuickCheck import Certificate import PubKey import PipeChan import Network.TLS import qualified Crypto.Random.AESCtr as RNG import qualified Data.ByteString as B debug = False blockCipher :: Cipher blockCipher = Cipher { cipherID = 0xff12 , cipherName = "rsa-id-const" , cipherBulk = Bulk { bulkName = "id" , bulkKeySize = 16 , bulkIVSize = 16 , bulkBlockSize = 16 , bulkF = BulkBlockF (\_ _ m -> m) (\_ _ m -> m) } , cipherHash = Hash { hashName = "const-hash" , hashSize = 16 , hashF = (\_ -> B.replicate 16 1) } , cipherKeyExchange = CipherKeyExchange_RSA , cipherMinVer = Nothing } streamCipher = blockCipher { cipherID = 0xff13 , cipherBulk = Bulk { bulkName = "stream" , bulkKeySize = 16 , bulkIVSize = 0 , bulkBlockSize = 0 , bulkF = BulkStreamF (\k -> k) (\i m -> (m,i)) (\i m -> (m,i)) } } supportedCiphers :: [Cipher] supportedCiphers = [blockCipher,streamCipher] supportedVersions :: [Version] supportedVersions = [SSL3,TLS10,TLS11,TLS12] arbitraryPairParams = do let (pubKey, privKey) = getGlobalRSAPair servCert <- arbitraryX509WithPublicKey pubKey allowedVersions <- arbitraryVersions connectVersion <- elements supportedVersions `suchThat` (\c -> c `elem` allowedVersions) serverCiphers <- arbitraryCiphers clientCiphers <- oneof [arbitraryCiphers] `suchThat` (\cs -> or [x `elem` serverCiphers | x <- cs]) secNeg <- arbitrary let serverState = defaultParamsServer { pAllowedVersions = allowedVersions , pCiphers = serverCiphers , pCertificates = [(servCert, Just $ PrivRSA privKey)] , pUseSecureRenegotiation = secNeg , pLogging = logging "server: " } let clientState = defaultParamsClient { pConnectVersion = connectVersion , pAllowedVersions = allowedVersions , pCiphers = clientCiphers , pUseSecureRenegotiation = secNeg , pLogging = logging "client: " } return (clientState, serverState) where logging pre = if debug then defaultLogging { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } else defaultLogging arbitraryVersions :: Gen [Version] arbitraryVersions = resize (length supportedVersions + 1) $ listOf1 (elements supportedVersions) arbitraryCiphers = resize (length supportedCiphers + 1) $ listOf1 (elements supportedCiphers) setPairParamsSessionManager :: SessionManager s => s -> (Params, Params) -> (Params, Params) setPairParamsSessionManager manager (clientState, serverState) = (nc,ns) where nc = setSessionManager manager clientState ns = setSessionManager manager serverState setPairParamsSessionResuming sessionStuff (clientState, serverState) = (nc,serverState) where nc = updateClientParams (\cparams -> cparams { clientWantSessionResume = Just sessionStuff }) clientState newPairContext pipe (cParams, sParams) = do let noFlush = return () let noClose = return () cRNG <- RNG.makeSystem sRNG <- RNG.makeSystem let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe) let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe) cCtx' <- contextNew cBackend cParams cRNG sCtx' <- contextNew sBackend sParams sRNG return (cCtx', sCtx')