tls 0.9.11 → 1.0.0
raw patch · 40 files changed
+3588/−2204 lines, 40 filesdep +networkdep ~basedep ~certificatedep ~cryptocipher
Dependencies added: network
Dependency ranges changed: base, certificate, cryptocipher
Files
- LICENSE +1/−1
- Network/TLS.hs +87/−45
- Network/TLS/Cap.hs +3/−3
- Network/TLS/Cipher.hs +49/−48
- Network/TLS/Compression.hs +22/−18
- Network/TLS/Context.hs +310/−163
- Network/TLS/Core.hs +59/−502
- Network/TLS/Crypto.hs +51/−36
- Network/TLS/Extension.hs +134/−0
- Network/TLS/Handshake.hs +41/−0
- Network/TLS/Handshake/Certificate.hs +30/−0
- Network/TLS/Handshake/Client.hs +268/−0
- Network/TLS/Handshake/Common.hs +123/−0
- Network/TLS/Handshake/Server.hs +325/−0
- Network/TLS/Handshake/Signature.hs +39/−0
- Network/TLS/IO.hs +91/−0
- Network/TLS/Internal.hs +7/−7
- Network/TLS/MAC.hs +40/−33
- Network/TLS/Measurement.hs +18/−18
- Network/TLS/Packet.hs +261/−247
- Network/TLS/Receiving.hs +95/−75
- Network/TLS/Record.hs +14/−14
- Network/TLS/Record/Disengage.hs +69/−72
- Network/TLS/Record/Engage.hs +43/−43
- Network/TLS/Record/Types.hs +24/−24
- Network/TLS/Sending.hs +26/−24
- Network/TLS/Session.hs +30/−0
- Network/TLS/State.hs +357/−201
- Network/TLS/Struct.hs +333/−314
- Network/TLS/Types.hs +38/−0
- Network/TLS/Util.hs +34/−29
- Network/TLS/Wire.hs +56/−40
- README.md +0/−45
- TODO +0/−27
- Tests.hs +220/−170
- Tests/Certificate.hs +57/−0
- Tests/Connection.hs +123/−0
- Tests/PipeChan.hs +56/−0
- Tests/PubKey.hs +32/−0
- tls.cabal +22/−5
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2010-2012 Vincent Hanquez <vincent@snarc.org> All rights reserved.
Network/TLS.hs view
@@ -6,57 +6,99 @@ -- Portability : unknown -- module Network.TLS- (- -- * Context configuration- TLSParams(..)- , TLSLogging(..)- , TLSCertificateUsage(..)- , TLSCertificateRejectReason(..)- , defaultParams- , defaultLogging- , SessionID- , SessionData(..)+ (+ -- * Context configuration+ Params(..)+ , RoleParams(..)+ , ClientParams(..)+ , ServerParams(..)+ , updateClientParams+ , updateServerParams+ , Logging(..)+ , Measurement(..)+ , CertificateUsage(..)+ , CertificateRejectReason(..)+ , defaultParamsClient+ , defaultParamsServer+ , defaultLogging+ , MaxFragmentEnum(..)+ , HashAndSignatureAlgorithm+ , HashAlgorithm(..)+ , SignatureAlgorithm(..)+ , CertificateType(..) - -- * Context object- , TLSCtx- , ctxConnection+ -- * raw types+ , ProtocolType(..)+ , Header(..) - -- * Creating a context- , client- , server- , clientWith- , serverWith+ -- * Session+ , SessionID+ , SessionData(..)+ , SessionManager(..)+ , NoSessionManager(..)+ , setSessionManager - -- * Initialisation and Termination of context- , bye- , handshake+ -- * Backend abstraction+ , Backend(..) - -- * High level API- , sendData- , recvData- , recvData'+ -- * Context object+ , Context+ , ctxConnection - -- * Crypto Key- , PrivateKey(..)- -- * Compressions & Predefined compressions- , CompressionC(..)- , Compression(..)- , nullCompression- -- * Ciphers & Predefined ciphers- , Cipher(..)- , Bulk(..)- -- * Versions- , Version(..)- -- * Errors- , TLSError(..)- -- * Exceptions- , HandshakeFailed(..)- , ConnectionNotEstablished(..)- ) where+ -- * Creating a context+ , contextNew+ , contextNewOnHandle+ , contextFlush+ , contextClose -import Network.TLS.Struct (Version(..), TLSError(..), SessionID)-import Network.TLS.Crypto (PrivateKey(..))-import Network.TLS.Cipher (Cipher(..), Bulk(..))+ -- * 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+ , 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
Network/TLS/Cap.hs view
@@ -7,9 +7,9 @@ -- module Network.TLS.Cap- ( hasHelloExtensions- , hasExplicitBlockIV- ) where+ ( hasHelloExtensions+ , hasExplicitBlockIV+ ) where import Network.TLS.Struct
Network/TLS/Cipher.hs view
@@ -8,18 +8,19 @@ -- Portability : unknown -- module Network.TLS.Cipher- ( BulkFunctions(..)- , CipherKeyExchangeType(..)- , Bulk(..)- , Hash(..)- , Cipher(..)- , cipherKeyBlockSize- , Key- , IV- , cipherExchangeNeedMoreData- ) where+ ( BulkFunctions(..)+ , CipherKeyExchangeType(..)+ , Bulk(..)+ , Hash(..)+ , Cipher(..)+ , CipherID+ , cipherKeyBlockSize+ , Key+ , IV+ , cipherExchangeNeedMoreData+ ) where -import Data.Word+import Network.TLS.Types (CipherID) import Network.TLS.Struct (Version(..)) import qualified Data.ByteString as B@@ -29,59 +30,59 @@ type IV = B.ByteString data BulkFunctions =- BulkNoneF -- special value for 0- | 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))+ BulkNoneF -- special value for 0+ | 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)+ 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- }+ { bulkName :: String+ , bulkKeySize :: Int+ , bulkIVSize :: Int+ , bulkBlockSize :: Int+ , bulkF :: BulkFunctions+ } data Hash = Hash- { hashName :: String- , hashSize :: Int- , hashF :: B.ByteString -> B.ByteString- }+ { hashName :: String+ , hashSize :: Int+ , hashF :: B.ByteString -> B.ByteString+ } -- | Cipher algorithm data Cipher = Cipher- { cipherID :: Word16- , cipherName :: String- , cipherHash :: Hash- , cipherBulk :: Bulk- , cipherKeyExchange :: CipherKeyExchangeType- , cipherMinVer :: Maybe Version- }+ { 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+ where bulk = cipherBulk cipher instance Show Cipher where- show c = cipherName c+ show c = cipherName c instance Eq Cipher where- (==) c1 c2 = cipherID c1 == cipherID c2+ (==) c1 c2 = cipherID c1 == cipherID c2 cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool cipherExchangeNeedMoreData CipherKeyExchange_RSA = False
Network/TLS/Compression.hs view
@@ -8,34 +8,37 @@ -- Portability : unknown -- module Network.TLS.Compression- ( CompressionC(..)- , Compression(..)- , nullCompression+ ( CompressionC(..)+ , Compression(..)+ , CompressionID+ , nullCompression+ , NullCompression - -- * member redefined for the class abstraction- , compressionID- , compressionDeflate- , compressionInflate+ -- * member redefined for the class abstraction+ , compressionID+ , compressionDeflate+ , compressionInflate - -- * helper- , compressionIntersectID- ) where+ -- * 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 -> Word8- compressionCDeflate :: a -> ByteString -> (a, ByteString)- compressionCInflate :: a -> ByteString -> (a, ByteString)+ 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 -> Word8+compressionID :: Compression -> CompressionID compressionID (Compression c) = compressionCID c -- | deflate (compress) a bytestring using a compression context and return the result@@ -49,7 +52,7 @@ compressionInflate bytes (Compression c) = first Compression $ compressionCInflate c bytes instance Show Compression where- show = show . compressionID+ 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@@ -57,12 +60,13 @@ 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)+ compressionCID _ = 0+ compressionCDeflate s b = (s, b)+ compressionCInflate s b = (s, b) -- | default null compression nullCompression :: Compression
Network/TLS/Context.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Context -- License : BSD-style@@ -6,45 +5,74 @@ -- 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- TLSParams(..)- , TLSLogging(..)- , SessionData(..)- , Measurement(..)- , TLSCertificateUsage(..)- , TLSCertificateRejectReason(..)- , defaultLogging- , defaultParams+ (+ -- * Context configuration+ Params(..)+ , RoleParams(..)+ , ClientParams(..)+ , ServerParams(..)+ , updateClientParams+ , updateServerParams+ , Logging(..)+ , SessionID+ , SessionData(..)+ , MaxFragmentEnum(..)+ , Measurement(..)+ , CertificateUsage(..)+ , CertificateRejectReason(..)+ , defaultLogging+ , defaultParamsClient+ , defaultParamsServer+ , withSessionManager+ , setSessionManager - -- * Context object and accessor- , TLSCtx- , ctxParams- , ctxConnection- , ctxEOF- , ctxEstablished- , ctxLogging- , setEOF- , setEstablished- , connectionFlush- , connectionSend- , connectionRecv- , updateMeasure- , withMeasure+ -- * Context object and accessor+ , Backend(..)+ , Context+ , ctxParams+ , ctxConnection+ , ctxEOF+ , ctxEstablished+ , ctxLogging+ , setEOF+ , setEstablished+ , contextFlush+ , contextClose+ , contextSend+ , contextRecv+ , updateMeasure+ , withMeasure - -- * New contexts- , newCtxWith- , newCtx+ -- * deprecated types+ , TLSParams+ , TLSLogging+ , TLSCertificateUsage+ , TLSCertificateRejectReason+ , TLSCtx - -- * Using context states- , throwCore- , usingState- , usingState_- , getStateRNG- ) where+ -- * 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@@ -52,180 +80,299 @@ 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+ import Control.Concurrent.MVar import Control.Monad.State import Control.Exception (throwIO, Exception()) import Data.IORef-import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush)+import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) -#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif+data Logging = Logging+ { loggingPacketSent :: String -> IO ()+ , loggingPacketRecv :: String -> IO ()+ , loggingIOSent :: B.ByteString -> IO ()+ , loggingIORecv :: Header -> B.ByteString -> IO ()+ } -data TLSLogging = TLSLogging- { 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. -data TLSParams = TLSParams- { 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.- , pWantClientCert :: Bool -- ^ request a certificate from client.- -- use by server only.- , 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 :: TLSLogging -- ^ callback for logging- , onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake- , onCertificatesRecv :: [X509] -> IO TLSCertificateUsage -- ^ callback to verify received cert chain.- , onSessionResumption :: SessionID -> IO (Maybe SessionData) -- ^ callback to maybe resume session on server.- , onSessionEstablished :: SessionID -> SessionData -> IO () -- ^ callback when session have been established- , onSessionInvalidated :: SessionID -> IO () -- ^ callback when session is invalidated by error- , sessionResumeWith :: 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)]+ } -defaultLogging :: TLSLogging-defaultLogging = TLSLogging- { loggingPacketSent = (\_ -> return ())- , loggingPacketRecv = (\_ -> return ())- , loggingIOSent = (\_ -> return ())- , loggingIORecv = (\_ _ -> return ())- }+data ServerParams = ServerParams+ { serverWantClientCert :: Bool -- ^ request a certificate from client. -defaultParams :: TLSParams-defaultParams = TLSParams- { pConnectVersion = TLS10- , pAllowedVersions = [TLS10,TLS11,TLS12]- , pCiphers = []- , pCompressions = [nullCompression]- , pWantClientCert = False- , pUseSecureRenegotiation = True- , pUseSession = True- , pCertificates = []- , pLogging = defaultLogging- , onHandshake = (\_ -> return True)- , onCertificatesRecv = (\_ -> return CertificateUsageAccept)- , onSessionResumption = (\_ -> return Nothing)- , onSessionEstablished = (\_ _ -> return ())- , onSessionInvalidated = (\_ -> return ())- , sessionResumeWith = Nothing- }+ -- | 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] -instance Show TLSParams where- show p = "TLSParams { " ++ (intercalate "," $ map (\(k,v) -> k ++ "=" ++ v)- [ ("connectVersion", show $ pConnectVersion p)- , ("allowedVersions", show $ pAllowedVersions p)- , ("ciphers", show $ pCiphers p)- , ("compressions", show $ pCompressions p)- , ("want-client-cert", show $ pWantClientCert p)- , ("certificates", show $ length $ pCertificates p)- ]) ++ " }"+ -- | 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 :: Maybe KxError -> 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 TLSCertificateRejectReason =- CertificateRejectExpired- | CertificateRejectRevoked- | CertificateRejectUnknownCA- | CertificateRejectOther String- deriving (Show,Eq)+data CertificateRejectReason =+ CertificateRejectExpired+ | CertificateRejectRevoked+ | CertificateRejectUnknownCA+ | CertificateRejectOther String+ deriving (Show,Eq) -- | Certificate Usage callback possible returns values.-data TLSCertificateUsage =- CertificateUsageAccept -- ^ usage of certificate accepted- | CertificateUsageReject TLSCertificateRejectReason -- ^ usage of certificate rejected- deriving (Show,Eq)+data CertificateUsage =+ CertificateUsageAccept -- ^ usage of certificate accepted+ | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected+ deriving (Show,Eq) --- | A TLS Context is a handle augmented by tls specific state and parameters-data TLSCtx a = TLSCtx- { ctxConnection :: a -- ^ return the connection object associated with this context- , ctxParams :: TLSParams- , 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.- , ctxConnectionFlush :: IO ()- , ctxConnectionSend :: Bytes -> IO ()- , ctxConnectionRecv :: Int -> IO Bytes- }+-- | 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.+ } -updateMeasure :: MonadIO m => TLSCtx c -> (Measurement -> Measurement) -> m ()+-- | 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.+ }++-- 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 => TLSCtx c -> (Measurement -> IO a) -> m a+withMeasure :: MonadIO m => Context -> (Measurement -> IO a) -> m a withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f) -connectionFlush :: TLSCtx c -> IO ()-connectionFlush c = ctxConnectionFlush c+contextFlush :: Context -> IO ()+contextFlush = backendFlush . ctxConnection -connectionSend :: TLSCtx c -> Bytes -> IO ()-connectionSend c b = updateMeasure c (addBytesSent $ B.length b) >> (ctxConnectionSend c) b+contextClose :: Context -> IO ()+contextClose = backendClose . ctxConnection -connectionRecv :: TLSCtx c -> Int -> IO Bytes-connectionRecv c sz = updateMeasure c (addBytesReceived sz) >> (ctxConnectionRecv c) sz+contextSend :: Context -> Bytes -> IO ()+contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b -ctxEOF :: MonadIO m => TLSCtx a -> m Bool+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) -setEOF :: MonadIO m => TLSCtx c -> m ()+setEOF :: MonadIO m => Context -> m () setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True -ctxEstablished :: MonadIO m => TLSCtx a -> m Bool+ctxEstablished :: MonadIO m => Context -> m Bool ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx -setEstablished :: MonadIO m => TLSCtx c -> Bool -> m ()+setEstablished :: MonadIO m => Context -> Bool -> m () setEstablished ctx v = liftIO $ writeIORef (ctxEstablished_ ctx) v -ctxLogging :: TLSCtx a -> TLSLogging+ctxLogging :: Context -> Logging ctxLogging = pLogging . ctxParams -newCtxWith :: c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> TLSParams -> TLSState -> IO (TLSCtx c)-newCtxWith c flushF sendF recvF params st = do- stvar <- newMVar st- eof <- newIORef False- established <- newIORef False- stats <- newIORef newMeasurement- return $ TLSCtx- { ctxConnection = c- , ctxParams = params- , ctxState = stvar- , ctxMeasurement = stats- , ctxEOF_ = eof- , ctxEstablished_ = established- , ctxConnectionFlush = flushF- , ctxConnectionSend = sendF- , ctxConnectionRecv = recvF- }+-- | create a new context using the backend and parameters specified.+contextNew :: (MonadIO m, CryptoRandomGen rng)+ => Backend -- ^ Backend abstraction with specific method to interacat 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 -newCtx :: Handle -> TLSParams -> TLSState -> IO (TLSCtx Handle)-newCtx handle params st = do- hSetBuffering handle NoBuffering- newCtxWith handle (hFlush handle) (B.hPut handle) (B.hGet handle) params st+ 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+ return $ Context+ { ctxConnection = backend+ , ctxParams = params+ , ctxState = stvar+ , ctxMeasurement = stats+ , ctxEOF_ = eof+ , ctxEstablished_ = established+ }++-- | create a new context on an handle.+contextNewOnHandle :: (MonadIO m, CryptoRandomGen 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 => TLSCtx c -> TLSSt a -> m (Either TLSError a)+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)+ liftIO $ modifyMVar (ctxState ctx) $ \st ->+ let (a, newst) = runTLSState f st+ in newst `seq` return (newst, a) -usingState_ :: MonadIO m => TLSCtx c -> TLSSt a -> m 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+ ret <- usingState ctx f+ case ret of+ Left err -> throwCore err+ Right r -> return r -getStateRNG :: MonadIO m => TLSCtx c -> Int -> m Bytes+getStateRNG :: MonadIO m => Context -> Int -> m Bytes getStateRNG ctx n = usingState_ ctx (genTLSRandom n)-
Network/TLS/Core.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Core -- License : BSD-style@@ -9,531 +8,89 @@ -- Portability : unknown -- module Network.TLS.Core- (- -- * Internal packet sending and receiving- sendPacket- , recvPacket+ (+ -- * Internal packet sending and receiving+ sendPacket+ , recvPacket - -- * Creating a client or server context- , client- , clientWith- , server- , serverWith+ -- * Initialisation and Termination of context+ , bye+ , handshake+ , HandshakeFailed(..)+ , ConnectionNotEstablished(..) - -- * Initialisation and Termination of context- , bye- , handshake- , HandshakeFailed(..)- , ConnectionNotEstablished(..)+ -- * Next Protocol Negotiation+ , getNegotiatedProtocol - -- * High level API- , sendData- , recvData- , recvData'- ) where+ -- * High level API+ , sendData+ , recvData+ , recvData'+ ) where import Network.TLS.Context import Network.TLS.Struct-import Network.TLS.Record-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Packet-import Network.TLS.State-import Network.TLS.Sending-import Network.TLS.Receiving-import Network.TLS.Measurement-import Network.TLS.Wire (encodeWord16)-import Data.Maybe-import Data.Data-import Data.List (intersect, find)+import Network.TLS.IO+import Network.TLS.Handshake+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 Crypto.Random-import Control.Applicative ((<$>)) import Control.Monad.State-import Control.Exception (throwIO, Exception(), fromException, catch, SomeException)-import System.IO (Handle)-import System.IO.Error (mkIOError, eofErrorType)-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif -data HandshakeFailed = HandshakeFailed TLSError- deriving (Show,Eq,Typeable)--data ConnectionNotEstablished = ConnectionNotEstablished- deriving (Show,Eq,Typeable)--instance Exception HandshakeFailed-instance Exception ConnectionNotEstablished--errorToAlert :: TLSError -> Packet-errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]-errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]--handshakeFailed :: TLSError -> IO ()-handshakeFailed err = throwIO $ HandshakeFailed err--checkValid :: MonadIO m => TLSCtx c -> 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 => TLSCtx c -> Int -> m Bytes-readExact ctx sz = do- hdrbs <- liftIO $ connectionRecv 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 => TLSCtx c -> m (Either TLSError (Record Plaintext))-recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader- where recvLength header@(Header _ _ readlen)- | readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow)- | otherwise = do- content <- readExact ctx (fromIntegral readlen)- 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 => TLSCtx c -> m (Either TLSError Packet)-recvPacket ctx = do- erecord <- recvRecord 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 ()- return pkt--recvPacketHandshake :: MonadIO m => TLSCtx c -> 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--data RecvState m =- RecvStateNext (Packet -> m (RecvState m))- | RecvStateHandshake (Handshake -> m (RecvState m))- | RecvStateDone--runRecvState :: MonadIO m => TLSCtx a -> 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--sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m ()-sendChangeCipherAndFinish ctx isClient = do- sendPacket ctx ChangeCipherSpec- liftIO $ connectionFlush ctx- cf <- usingState_ ctx $ getHandshakeDigest isClient- sendPacket ctx (Handshake [Finished cf])- liftIO $ connectionFlush ctx--recvChangeCipherAndFinish :: MonadIO m => TLSCtx c -> 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")--unexpected :: MonadIO m => String -> Maybe [Char] -> m a-unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)--newSession :: MonadIO m => TLSCtx c -> m Session-newSession ctx- | pUseSession $ ctxParams ctx = getStateRNG ctx 32 >>= return . Session . Just- | otherwise = return $ Session Nothing---- | Send one packet to the context-sendPacket :: MonadIO m => TLSCtx c -> 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 $ connectionSend ctx dataToSend- where- isNonNullAppData (AppData b) = not $ B.null b- isNonNullAppData _ = False---- | Create a new Client context with a configuration, a RNG, a generic connection and the connection operation.-clientWith :: (MonadIO m, CryptoRandomGen g)- => TLSParams -- ^ Parameters to use for this context- -> g -- ^ Random number generator associated- -> c -- ^ An abstract connection type- -> IO () -- ^ A method for the connection buffer to be flushed- -> (B.ByteString -> IO ()) -- ^ A method for sending bytes through the connection- -> (Int -> IO B.ByteString) -- ^ A method for receiving bytes through the connection- -> m (TLSCtx c)-clientWith params rng connection flushF sendF recvF =- liftIO $ newCtxWith connection flushF sendF recvF params st- where st = (newTLSState rng) { stClientContext = True }---- | Create a new Client context with a configuration, a RNG, and a Handle.--- It reconfigures the handle's 'System.IO.BufferMode' to @NoBuffering@.-client :: (MonadIO m, CryptoRandomGen g)- => TLSParams -- ^ parameters to use for this context- -> g -- ^ random number generator associated with the context- -> Handle -- ^ handle to use- -> m (TLSCtx Handle)-client params rng handle = liftIO $ newCtx handle params st- where st = (newTLSState rng) { stClientContext = True }---- | Create a new Server context with a configuration, a RNG, a generic connection and the connection operation.-serverWith :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> c -> IO () -> (B.ByteString -> IO ()) -> (Int -> IO B.ByteString) -> m (TLSCtx c)-serverWith params rng connection flushF sendF recvF =- liftIO $ newCtxWith connection flushF sendF recvF params st- where st = (newTLSState rng) { stClientContext = False }---- | Create a new Server context with a configuration, a RNG, and a Handle.--- It reconfigures the handle's 'System.IO.BufferMode' to @NoBuffering@.-server :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle)-server params rng handle = liftIO $ newCtx handle params st- where st = (newTLSState rng) { stClientContext = False }- -- | 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 => TLSCtx c -> m ()+bye :: MonadIO m => Context -> m () bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] --- | when a new handshake is done, wrap up & clean up.-handshakeTerminate :: MonadIO m => TLSCtx c -> 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- liftIO $ (onSessionEstablished $ ctxParams ctx) 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 ()---- client part of handshake. send a bunch of handshake of client--- values intertwined with response from the server.-handshakeClient :: MonadIO m => TLSCtx c -> m ()-handshakeClient ctx = do- updateMeasure ctx incrementNbHandshakes- sendClientHello- recvServerHello- sessionResuming <- usingState_ ctx isSessionResuming- if sessionResuming- then sendChangeCipherAndFinish ctx True- else do- sendCertificate >> sendClientKeyXchg >> sendCertificateVerify- sendChangeCipherAndFinish ctx True- recvChangeCipherAndFinish ctx- handshakeTerminate ctx- where- params = ctxParams ctx- ver = pConnectVersion params- allowedvers = pAllowedVersions params- ciphers = pCiphers params- compressions = pCompressions params- clientCerts = map fst $ pCertificates params- getExtensions =- if pUseSecureRenegotiation params- then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ]- else return []-- sendClientHello = do- crand <- getStateRNG ctx 32 >>= return . ClientRandom- let clientSession = Session . maybe Nothing (Just . fst) $ sessionResumeWith params- extensions <- getExtensions- usingState_ ctx (startHandshakeClient ver crand)- sendPacket ctx $ Handshake- [ ClientHello ver crand clientSession (map cipherID ciphers)- (map compressionID compressions) 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")-- sendCertificate = do- -- Send Certificate if requested. XXX disabled for now.- certRequested <- return False- when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])-- sendCertificateVerify =- {- maybe send certificateVerify -}- {- FIXME not implemented yet -}- return ()-- recvServerHello = runRecvState ctx (RecvStateHandshake onServerHello)-- onServerHello :: MonadIO m => Handshake -> m (RecvState m)- onServerHello sh@(ServerHello rver _ serverSession cipher _ _) = do- when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)- case find ((==) rver) allowedvers of- Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)- Just _ -> usingState_ ctx $ setVersion ver- 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-- let resumingSession = case sessionResumeWith params 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 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 $ catch (onCertificatesRecv params $ certs) rejectOnException- case usage of- CertificateUsageAccept -> return ()- CertificateUsageReject reason -> certificateRejected reason- return $ RecvStateHandshake processServerKeyExchange- where- rejectOnException :: SomeException -> IO TLSCertificateUsage- rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e- processCertificate p = processServerKeyExchange p-- processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m)- processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest- processServerKeyExchange p = processCertificateRequest p-- processCertificateRequest (CertRequest _ _ _) = do- --modify (\sc -> sc { scCertRequested = True })- return $ RecvStateHandshake processServerHelloDone- processCertificateRequest p = processServerHelloDone p-- processServerHelloDone ServerHelloDone = return RecvStateDone- processServerHelloDone p = unexpected (show p) (Just "server hello data")-- 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]-- -- on certificate reject, throw an exception with the proper protocol alert error.- 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)--handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m ()-handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers compressions _) = 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 (commonCiphers == []) $- 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- , stCipher = Just usedCipher- , stCompression = usedCompression- })-- resumeSessionData <- case clientSession of- (Session (Just clientSessionId)) -> liftIO $ onSessionResumption params $ clientSessionId- (Session Nothing) -> return Nothing- case resumeSessionData of- Nothing -> do- handshakeSendServerData- liftIO $ connectionFlush ctx-- -- Receive client info until client Finished.- recvClientData- 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- commonCiphers = intersect ciphers (map cipherID $ pCiphers params)- usedCipher = fromJust $ find (\c -> cipherID c == head commonCiphers) (pCiphers params)- commonCompressions = compressionIntersectID (pCompressions params) compressions- usedCompression = head commonCompressions- srvCerts = map fst $ pCertificates params- privKeys = map snd $ pCertificates params- needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher-- ---- recvClientData = runRecvState ctx (RecvStateHandshake $ processClientCertificate)-- processClientCertificate (Certificates _) = return $ RecvStateHandshake processClientKeyExchange- processClientCertificate p = processClientKeyExchange p-- processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify- processClientKeyExchange p = unexpected (show p) (Just "client key exchange")-- processCertificateVerify (Handshake [CertVerify _]) = return $ RecvStateNext expectChangeCipher- processCertificateVerify p = expectChangeCipher p-- 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")- ----- 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- extensions <- if secReneg- then do- vf <- usingState_ ctx $ do- cvf <- getVerifiedData True- svf <- getVerifiedData False- return $ encodeExtSecureRenegotiation cvf (Just svf)- return [ (0xff01, vf) ]- else return []- 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 (pWantClientCert params) $ do- let certTypes = [ CertificateType_RSA_Sign ]- let creq = CertRequest certTypes Nothing [0,0,0]- sendPacket ctx (Handshake [creq])- -- Send HelloDone- sendPacket ctx (Handshake [ServerHelloDone])--handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello"---- after receiving a client hello, we need to redo a handshake-handshakeServer :: MonadIO m => TLSCtx c -> m ()-handshakeServer ctx = do- hss <- recvPacketHandshake ctx- case hss of- [ch] -> handshakeServerWith ctx ch- _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss)---- | Handshake for a new TLS connection--- This is to be called at the beginning of a connection, and during renegotiation-handshake :: MonadIO m => TLSCtx c -> m ()-handshake ctx = do- cc <- usingState_ ctx (stClientContext <$> get)- liftIO $ handleException $ if cc then handshakeClient ctx else handshakeServer ctx- where- handleException f = catch f $ \exception -> do- let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception- setEstablished ctx False- sendPacket ctx (errorToAlert tlserror)- handshakeFailed tlserror+-- | 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 => TLSCtx c -> L.ByteString -> m ()+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+ 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 => TLSCtx c -> m B.ByteString+recvData :: MonadIO m => Context -> m B.ByteString recvData ctx = do- checkValid ctx- pkt <- recvPacket ctx- case pkt of- -- on server context receiving a client hello == renegotiation- Right (Handshake [ch@(ClientHello _ _ _ _ _ _)]) ->- handshakeServerWith ctx ch >> recvData ctx- -- on client context, receiving a hello request == renegotiation- Right (Handshake [HelloRequest]) ->- handshakeClient ctx >> recvData ctx- Right (Alert [(AlertLevel_Fatal, _)]) -> do- setEOF ctx- return B.empty- Right (Alert [(AlertLevel_Warning, CloseNotify)]) -> do- setEOF ctx- return B.empty- Right (AppData x) -> return x- Right p -> error ("error unexpected packet: " ++ show p)- Left err -> error ("error received: " ++ show err)+ checkValid ctx+ pkt <- recvPacket ctx+ case pkt of+ -- on server context receiving a client hello == renegotiation+ Right (Handshake [ch@(ClientHello {})]) ->+ case roleParams $ ctxParams ctx of+ Server sparams -> handshakeServerWith sparams ctx ch >> recvData ctx+ Client {} -> error "assert, unexpected client hello in client context"+ -- on client context, receiving a hello request == renegotiation+ Right (Handshake [HelloRequest]) ->+ case roleParams $ ctxParams ctx of+ Server {} -> error "assert, unexpected hello request in server context"+ Client cparams -> handshakeClient cparams ctx >> recvData ctx+ Right (Alert [(AlertLevel_Fatal, _)]) -> do+ setEOF ctx+ return B.empty+ Right (Alert [(AlertLevel_Warning, CloseNotify)]) -> do+ setEOF ctx+ return B.empty+ Right (AppData x) -> return x+ Right p -> error ("error unexpected packet: " ++ show p)+ Left err -> error ("error received: " ++ show err) -recvData' :: MonadIO m => TLSCtx c -> m L.ByteString+{-# 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 . (:[])
Network/TLS/Crypto.hs view
@@ -1,23 +1,25 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Crypto- ( HashCtx(..)- , hashInit- , hashUpdate- , hashUpdateSSL- , hashFinal+ ( HashCtx(..)+ , hashInit+ , hashUpdate+ , hashUpdateSSL+ , hashFinal - -- * constructor- , hashMD5SHA1- , hashSHA256+ -- * constructor+ , hashMD5SHA1+ , hashSHA256 - -- * key exchange generic interface- , PublicKey(..)- , PrivateKey(..)- , kxEncrypt- , kxDecrypt- , KxError(..)- ) where+ -- * key exchange generic interface+ , PublicKey(..)+ , PrivateKey(..)+ , kxEncrypt+ , kxDecrypt+ , kxSign+ , kxVerify+ , KxError(..)+ ) where import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA1 as SHA1@@ -32,48 +34,48 @@ data PrivateKey = PrivRSA RSA.PrivateKey instance Show PublicKey where- show (_) = "PublicKey(..)"+ show (_) = "PublicKey(..)" instance Show PrivateKey where- show (_) = "privateKey(..)"+ show (_) = "privateKey(..)" data KxError = RSAError RSA.Error- deriving (Show)+ deriving (Show) data KeyXchg =- KxRSA RSA.PublicKey RSA.PrivateKey- deriving (Show)+ KxRSA RSA.PublicKey RSA.PrivateKey+ 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+ 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+ 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]+ 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+ 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@@ -103,3 +105,16 @@ kxDecrypt :: PrivateKey -> ByteString -> Either KxError ByteString kxDecrypt (PrivRSA pk) b = generalizeRSAError $ RSA.decrypt pk b++-- Verify that the signature matches the given message, using the+-- public key.+--+kxVerify :: PublicKey -> (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> Either KxError Bool+kxVerify (PubRSA pk) (hashF, hashASN1) msg sign =+ generalizeRSAError $ RSA.verify hashF hashASN1 pk msg sign++-- Sign the given message using the private key.+--+kxSign :: PrivateKey -> (ByteString -> ByteString, ByteString) -> ByteString -> Either KxError ByteString+kxSign (PrivRSA pk) (hashF, hashASN1) msg =+ generalizeRSAError $ RSA.sign hashF hashASN1 pk msg
+ Network/TLS/Extension.hs view
@@ -0,0 +1,134 @@+-- |+-- Module : Network.TLS.Extension+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 $ 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 >> putOpaque16 opaque+ extensionDecode _ = runGetMaybe (remaining >>= \len -> getList 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
+ Network/TLS/Handshake.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+-- |+-- Module : Network.TLS.Handshake+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Network/TLS/Handshake/Certificate.hs view
@@ -0,0 +1,30 @@+-- |+-- Module : Network.TLS.Handshake.Certificate+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Network/TLS/Handshake/Client.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+-- |+-- Module : Network.TLS.Handshake.Client+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 [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+ 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+ ]+ 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 = (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 = (hashf, "")++ 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
+ Network/TLS/Handshake/Common.hs view
@@ -0,0 +1,123 @@+{-# 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+
+ Network/TLS/Handshake/Server.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+-- |+-- Module : Network.TLS.Handshake.Server+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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+ , stCipher = 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 = (id, "")+ return (digest, hsh)++ x | x == TLS10 || x == TLS11 -> do+ let hashf bs' = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs')+ hsh = (hashf, "")+ 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+ Right True -> do+ -- When verification succeeds, commit the+ -- client certificate chain to the context.+ --+ Just certs <- usingState_ ctx $ getClientCertChain+ usingState_ ctx $ setClientCertificateChain certs+ return ()++ _ -> 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.+ let arg = case verif of+ Left err -> Just err+ _ -> Nothing+ res <- liftIO $ onUnverifiedClientCert sparams arg+ 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 do+ case verif of+ Left err -> throwCore $ Error_Protocol (show err, True, DecryptError)+ _ -> 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")
+ Network/TLS/Handshake/Signature.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Network.TLS.Handshake.Signature+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Handshake.Signature+ ( getHashAndASN1+ ) where++import qualified Crypto.Hash.SHA224 as SHA224+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Hash.SHA384 as SHA384+import qualified Crypto.Hash.SHA512 as SHA512++import Network.TLS.Context+import Network.TLS.Struct++import Control.Monad.State++import qualified Data.ByteString as B++getHashAndASN1 :: MonadIO m => (HashAlgorithm, SignatureAlgorithm) -> m (B.ByteString -> B.ByteString, B.ByteString)+getHashAndASN1 hashSig = do+ case hashSig of+ (HashSHA224, SignatureRSA) ->+ return (SHA224.hash, "\x30\x2d\x30\x0d\x06\x09\x60\x86\x48\x01\x65\x03\x04\x02\x04\x05\x00\x04\x1c")+ (HashSHA256, SignatureRSA) ->+ return (SHA256.hash, "\x30\x31\x30\x0d\x06\x09\x60\x86\x48\x01\x65\x03\x04\x02\x01\x05\x00\x04\x20")+ (HashSHA384, SignatureRSA) ->+ return (SHA384.hash, "\x30\x41\x30\x0d\x06\x09\x60\x86\x48\x01\x65\x03\x04\x02\x02\x05\x00\x04\x30")+ (HashSHA512, SignatureRSA) ->+ return (SHA512.hash, "\x30\x51\x30\x0d\x06\x09\x60\x86\x48\x01\x65\x03\x04\x02\x03\x05\x00\x04\x40")+ _ ->+ throwCore $ Error_Misc "unsupported hash/sig algorithm"++
+ Network/TLS/IO.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module : Network.TLS.IO+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 => Context -> m (Either TLSError (Record Plaintext))+recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader+ where recvLength header@(Header _ _ readlen)+ | readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow)+ | otherwise = do+ content <- readExact ctx (fromIntegral readlen)+ 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+ erecord <- recvRecord 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 ()+ 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
Network/TLS/Internal.hs view
@@ -7,13 +7,13 @@ -- 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+ ( 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
Network/TLS/MAC.hs view
@@ -1,14 +1,21 @@+-- |+-- Module : Network.TLS.MAC+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+-- module Network.TLS.MAC- ( hmacMD5- , hmacSHA1- , hmacSHA256- , macSSL- , hmac- , prf_MD5- , prf_SHA1- , prf_SHA256- , prf_MD5SHA1- ) where+ ( 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@@ -21,22 +28,22 @@ 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+ 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'+ 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+ 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@@ -49,12 +56,12 @@ 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)+ 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@@ -64,11 +71,11 @@ 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+ 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
Network/TLS/Measurement.hs view
@@ -6,41 +6,41 @@ -- Portability : unknown -- module Network.TLS.Measurement- ( Measurement(..)- , newMeasurement- , addBytesReceived- , addBytesSent- , resetBytesCounters- , incrementNbHandshakes- ) where+ ( 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)+ { 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- }+ { nbHandshakes = 0+ , bytesReceived = 0+ , bytesSent = 0+ } addBytesReceived :: Int -> Measurement -> Measurement addBytesReceived sz measure =- measure { bytesReceived = bytesReceived measure + fromIntegral sz }+ measure { bytesReceived = bytesReceived measure + fromIntegral sz } addBytesSent :: Int -> Measurement -> Measurement addBytesSent sz measure =- measure { bytesSent = bytesSent measure + fromIntegral sz }+ 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 }+ measure { nbHandshakes = nbHandshakes measure + 1 }
Network/TLS/Packet.hs view
@@ -10,44 +10,42 @@ -- with only explicit parameters, no TLS state is involved here. -- module Network.TLS.Packet- (- -- * params for encoding and decoding- CurrentParams(..)- -- * marshall functions for header messages- , decodeHeader- , encodeHeader- , encodeHeaderNoVer -- use for SSL3+ (+ -- * params for encoding and decoding+ CurrentParams(..)+ -- * marshall functions for header messages+ , decodeHeader+ , encodeHeader+ , encodeHeaderNoVer -- use for SSL3 - -- * marshall functions for alert messages- , decodeAlert- , decodeAlerts- , encodeAlerts+ -- * marshall functions for alert messages+ , decodeAlert+ , decodeAlerts+ , encodeAlerts - -- * marshall functions for handshake messages- , decodeHandshakes- , decodeHandshake- , encodeHandshake- , encodeHandshakes- , encodeHandshakeHeader- , encodeHandshakeContent+ -- * marshall functions for handshake messages+ , decodeHandshakes+ , decodeHandshake+ , encodeHandshake+ , encodeHandshakes+ , encodeHandshakeHeader+ , encodeHandshakeContent - -- * marshall functions for change cipher spec message- , decodeChangeCipherSpec- , encodeChangeCipherSpec+ -- * marshall functions for change cipher spec message+ , decodeChangeCipherSpec+ , encodeChangeCipherSpec - , decodePreMasterSecret- , encodePreMasterSecret+ , decodePreMasterSecret+ , encodePreMasterSecret - -- * marshall extensions- , decodeExtSecureRenegotiation- , encodeExtSecureRenegotiation+ -- * generate things for packet content+ , generateMasterSecret+ , generateKeyBlock+ , generateClientFinished+ , generateServerFinished - -- * generate things for packet content- , generateMasterSecret- , generateKeyBlock- , generateClientFinished- , generateServerFinished- ) where+ , generateCertificateVerify_SSL+ ) where import Network.TLS.Struct import Network.TLS.Wire@@ -57,7 +55,7 @@ import Data.Bits ((.|.)) import Control.Applicative ((<$>)) import Control.Monad-import Data.Certificate.X509 (decodeCertificate, encodeCertificate, X509)+import Data.Certificate.X509 (decodeCertificate, encodeCertificate, X509, encodeDN, decodeDN) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..))@@ -70,42 +68,40 @@ import qualified Crypto.Hash.MD5 as MD5 data CurrentParams = CurrentParams- { cParamsVersion :: Version -- ^ current protocol version- , cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type- } deriving (Show,Eq)--runGetErr :: String -> Get a -> ByteString -> Either TLSError a-runGetErr lbl f = either (Left . Error_Packet_Parsing) Right . runGet lbl f+ { 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+ 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+ 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+ 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+ ty <- getWord8+ case valToType ty of+ Nothing -> fail ("invalid handshake type: " ++ show ty)+ Just t -> return t {- - decode and encode headers@@ -115,137 +111,156 @@ encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len)- {- FIXME check len <= 2^14 -}+ {- FIXME check len <= 2^14 -} encodeHeaderNoVer :: Header -> ByteString encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len)- {- FIXME check len <= 2^14 -}+ {- 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"+ 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+ 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)+ 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)+ 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 getAll >>= \l -> return (x : l)+ 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- HandshakeType_ClientKeyXchg -> decodeClientKeyXchg- HandshakeType_Finished -> decodeFinished+ 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 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+ 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 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+ 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- certs <- getWord24 >>= getCerts >>= return . map (decodeCertificate . L.fromChunks . (:[]))- let (l, r) = partitionEithers certs- if length l > 0- then fail ("error certificate parsing: " ++ show l)- else return $ Certificates r+ 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) -getSignatureHashAlgorithm :: Get (HashAlgorithm, SignatureAlgorithm)-getSignatureHashAlgorithm = do- h <- fromJust . valToType <$> getWord8- s <- fromJust . valToType <$> getWord8- return (h,s)+decodeNextProtocolNegotiation :: Get Handshake+decodeNextProtocolNegotiation = do+ opaque <- getOpaque8+ _ <- getOpaque8 -- ignore padding+ return $ HsNextProtocolNegotiation opaque -getSignatureHashAlgorithms :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ]-getSignatureHashAlgorithms 0 = return []-getSignatureHashAlgorithms len = liftM2 (:) getSignatureHashAlgorithm (getSignatureHashAlgorithms (len-2))+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+ certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 - sigHashAlgs <- if cParamsVersion cp >= TLS12- then do- sighashlen <- getWord16- Just <$> getSignatureHashAlgorithms (fromIntegral sighashlen)- else return Nothing- dNameLen <- getWord16- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"- dName <- getBytes $ fromIntegral dNameLen- return $ CertRequest certTypes sigHashAlgs (B.unpack dName)+ 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) -decodeCertVerify :: Get Handshake-decodeCertVerify =- {- FIXME -}- return $ CertVerify []+ 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) @@ -254,39 +269,39 @@ 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 }+ 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 }+ 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+ 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 = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in- B.concat [ header, content ]+ let content = runPut $ encodeHandshakeContent o in+ let len = fromIntegral $ B.length content in+ let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in+ B.concat [ header, content ] encodeHandshakes :: [Handshake] -> ByteString encodeHandshakes hss = B.concat $ map encodeHandshake hss@@ -297,42 +312,65 @@ encodeHandshakeContent :: Handshake -> Put encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts) = do- putVersion version- putClientRandom32 random- putSession session- putWords16 cipherIDs- putWords8 compressionIDs- putExtensions exts- return ()+ 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 ()+ 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+ putBytes content encodeHandshakeContent (ServerKeyXchg _) = do- -- FIXME- return ()+ -- 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- putBytes $ B.pack certAuthorities+ 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 -encodeHandshakeContent (CertVerify _) = undefined+ -- 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@@ -354,39 +392,31 @@ getSession :: Get Session getSession = do- len8 <- getWord8- case fromIntegral len8 of- 0 -> return $ Session Nothing- len -> Session . Just <$> getBytes len+ 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 -getCerts :: Int -> Get [Bytes]-getCerts 0 = return []-getCerts len = do- certlen <- getWord24- cert <- getBytes certlen- certxs <- getCerts (len - certlen - 3)- return (cert : certxs)- putCert :: X509 -> Put putCert cert = putOpaque24 (B.concat $ L.toChunks $ encodeCertificate cert) -getExtensions :: Int -> Get [Extension]+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+ extty <- getWord16+ extdatalen <- getWord16+ extdata <- getBytes $ fromIntegral extdatalen+ extxs <- getExtensions (len - fromIntegral extdatalen - 4)+ return $ (extty, extdata) : extxs -putExtension :: Extension -> Put+putExtension :: ExtensionRaw -> Put putExtension (ty, l) = putWord16 ty >> putOpaque16 l -putExtensions :: [Extension] -> Put+putExtensions :: [ExtensionRaw] -> Put putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) @@ -396,35 +426,16 @@ decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do- x <- getWord8- when (x /= 1) (fail "unknown change cipher spec content")+ x <- getWord8+ when (x /= 1) (fail "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) --{-- - decode and encode various extensions- -}-decodeExtSecureRenegotiation :: Bool -> Bytes -> Either TLSError (Bytes, Maybe Bytes)-decodeExtSecureRenegotiation isServerHello = runGetErr "ext-secure-renegotiation" $ do- l <- fromIntegral <$> getWord8- if isServerHello- then do- cvd <- getBytes (l `div` 2) - svd <- getBytes (l `div` 2)- return (cvd, Just svd)- else getBytes (l `div` 2) >>= \cvd -> return (cvd, Nothing)--encodeExtSecureRenegotiation :: Bytes -> Maybe Bytes -> Bytes-encodeExtSecureRenegotiation cvd msvd = runPut $ do- let svd = maybe B.empty id msvd- putOpaque8 (cvd `B.append` svd)- -- rsa pre master secret decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes) decodePreMasterSecret = runGetErr "pre-master-secret" $ do- liftM2 (,) getVersion (getBytes 46)+ liftM2 (,) getVersion (getBytes 46) encodePreMasterSecret :: Version -> Bytes -> Bytes encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes)@@ -436,16 +447,16 @@ 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 ]+ 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 ]+ prf premasterSecret seed 48+ where+ seed = B.concat [ "master secret", c, s ] generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes generateMasterSecret SSL2 = generateMasterSecret_SSL@@ -456,15 +467,15 @@ 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 ]+ 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 ]+ 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@@ -475,29 +486,32 @@ generateFinished_TLS :: PRF -> Bytes -> Bytes -> HashCtx -> Bytes generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12- where- seed = B.concat [ label, hashFinal hashctx ]+ 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 ]+ 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+ 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"+ | 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"+ | 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 ""
Network/TLS/Receiving.hs view
@@ -8,7 +8,8 @@ -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state ---module Network.TLS.Receiving (processHandshake, processPacket, processServerHello) where+module Network.TLS.Receiving (processHandshake, processPacket, processServerHello+ , verifyRSA) where import Control.Applicative ((<$>)) import Control.Monad.State@@ -24,6 +25,7 @@ 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@@ -37,70 +39,81 @@ processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do- returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment- switchRxEncryption- return ChangeCipherSpec+ returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment+ switchRxEncryption+ return ChangeCipherSpec processPacket (Record ProtocolType_Handshake ver fragment) = do- keyxchg <- getCipherKeyExchangeType- let currentparams = CurrentParams- { cParamsVersion = ver- , cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg- }- 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+ 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 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 -> when clientmode $ do processCertificates certs- ClientKeyXchg content -> unless clientmode $ do- processClientKeyXchg content- Finished fdata -> processClientFinished fdata- _ -> return ()- when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs)- where- -- secure renegotiation- processClientExtension (0xff01, content) = do- v <- getVerifiedData True- let bs = encodeExtSecureRenegotiation v Nothing- when (bs /= content) $ throwError $- Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure)- setSecureRenegotiation True- -- unknown extensions- processClientExtension _ = return ()+ 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- ver <- stVersion <$> get- rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get- return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent)+ ver <- stVersion <$> get+ rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get+ return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) +verifyRSA :: (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> TLSSt (Either KxError 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 = encodeExtSecureRenegotiation cv (Just sv)- when (bs /= content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)- return ()+ -- 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 ()+ processServerExtension _ = return () processServerHello _ = error "processServerHello called on wrong type" -- process the client key exchange message. the protocol expects the initial@@ -108,29 +121,36 @@ -- 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+ 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 ()+ cc <- stClientContext <$> get+ expected <- getHandshakeDigest (not cc)+ when (expected /= fdata) $ do+ throwError $ Error_Protocol("bad record mac", True, BadRecordMac)+ updateVerifiedData False fdata+ return () -processCertificates :: [X509] -> TLSSt ()-processCertificates certs = do- let (X509 mainCert _ _ _ _) = head certs- case certPubKey mainCert of- PubKeyRSA pubkey -> setPublicKey (PubRSA pubkey)- _ -> 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 ()
Network/TLS/Record.hs view
@@ -12,20 +12,20 @@ -- higher-level clients. -- module Network.TLS.Record- ( Record(..)- , Fragment- , fragmentGetBytes- , fragmentPlaintext- , fragmentCiphertext- , recordToRaw- , rawToRecord- , recordToHeader- , Plaintext- , Compressed- , Ciphertext- , engageRecord- , disengageRecord- ) where+ ( Record(..)+ , Fragment+ , fragmentGetBytes+ , fragmentPlaintext+ , fragmentCiphertext+ , recordToRaw+ , rawToRecord+ , recordToHeader+ , Plaintext+ , Compressed+ , Ciphertext+ , engageRecord+ , disengageRecord+ ) where import Network.TLS.Record.Types import Network.TLS.Record.Engage
Network/TLS/Record/Disengage.hs view
@@ -9,8 +9,8 @@ -- The record is decrypted, checked for integrity and then decompressed. -- module Network.TLS.Record.Disengage- ( disengageRecord- ) where+ ( disengageRecord+ ) where import Control.Monad.State import Control.Monad.Error@@ -30,88 +30,85 @@ uncompressRecord :: Record Compressed -> TLSSt (Record Plaintext) uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->- withCompression $ compressionInflate bytes+ withCompression $ compressionInflate bytes decryptRecord :: Record Ciphertext -> TLSSt (Record Compressed) decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do- st <- get- if stRxEncrypted st- then decryptData e >>= getCipherData record- else return e+ st <- get+ if stRxEncrypted st+ then decryptData e >>= getCipherData record+ 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 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)+ -- 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)+ unless (macValid &&! paddingValid) $ do+ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) - return $ cipherDataContent cdata+ return $ cipherDataContent cdata decryptData :: Bytes -> TLSSt CipherData decryptData econtent = do- st <- get-- let cipher = fromJust "cipher" $ stCipher st- let bulk = cipherBulk cipher- let cst = fromJust "rx crypt state" $ stRxCryptState st- let digestSize = hashSize $ cipherHash cipher- let writekey = cstKey cst+ st <- get - case bulkF bulk of- BulkNoneF -> do- let contentlen = B.length econtent - digestSize- case partition3 econtent (contentlen, digestSize, 0) of- Nothing ->- throwError $ Error_Misc "partition3 failed"- Just (content, mac, _) ->- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }- BulkBlockF _ decryptF -> do- {- update IV -}- let (iv, econtent') =- if hasExplicitBlockIV $ stVersion st- then B.splitAt (bulkIVSize bulk) econtent- else (cstIV cst, econtent)- let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent'- put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ let cipher = fromJust "cipher" $ stCipher st+ let bulk = cipherBulk cipher+ let cst = fromJust "rx crypt state" $ stActiveRxCryptState st+ let digestSize = hashSize $ cipherHash cipher+ let writekey = cstKey cst - let content' = decryptF writekey iv econtent'- let paddinglength = fromIntegral (B.last content') + 1- let contentlen = B.length content' - paddinglength - digestSize- let (content, mac, padding) = fromJust "p3" $ partition3 content' (contentlen, digestSize, paddinglength)- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Just padding- }- BulkStreamF initF _ decryptF -> do- 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' - digestSize- let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0)- put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }+ case bulkF bulk of+ BulkNoneF -> do+ let contentlen = B.length econtent - digestSize+ (content, mac) <- get2 econtent (contentlen, digestSize)+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ BulkBlockF _ decryptF -> do+ {- update IV -}+ (iv, econtent') <- if hasExplicitBlockIV $ stVersion st+ then get2 econtent (bulkIVSize bulk, B.length econtent - 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 - digestSize+ (content, mac, padding) <- get3 content' (contentlen, digestSize, paddinglength)+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just padding+ }+ BulkStreamF initF _ decryptF -> do+ 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' - digestSize+ (content, mac) <- get2 content' (contentlen, digestSize)+ put $ st { stActiveRxCryptState = Just $ cst { cstIV = newiv } }+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ where 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)
Network/TLS/Record/Engage.hs view
@@ -9,8 +9,8 @@ -- The record is compressed, added some integrity field, then encrypted. -- module Network.TLS.Record.Engage- ( engageRecord- ) where+ ( engageRecord+ ) where import Control.Monad.State @@ -28,8 +28,8 @@ compressRecord :: Record Plaintext -> TLSSt (Record Compressed) compressRecord record =- onRecordFragment record $ fragmentCompress $ \bytes -> do- withCompression $ compressionDeflate bytes+ onRecordFragment record $ fragmentCompress $ \bytes -> do+ withCompression $ compressionDeflate bytes {- - when Tx Encrypted is set, we pass the data through encryptContent, otherwise@@ -37,53 +37,53 @@ -} 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+ 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]+ digest <- makeDigest True (recordToHeader record) content+ encryptData $ B.concat [content, digest] encryptData :: ByteString -> TLSSt ByteString encryptData content = do- st <- get+ st <- get - let cipher = fromJust "cipher" $ stCipher st- let bulk = cipherBulk cipher- let cst = fromJust "tx crypt state" $ stTxCryptState st+ let cipher = fromJust "cipher" $ stCipher st+ let bulk = cipherBulk cipher+ let cst = fromJust "tx crypt state" $ stActiveTxCryptState st - let writekey = cstKey cst+ let writekey = cstKey cst - case bulkF bulk of- BulkNoneF -> return content- 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+ case bulkF bulk of+ BulkNoneF -> return content+ 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 { stTxCryptState = 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 { stTxCryptState = Just $ cst { cstIV = newiv } }- return e+ -- 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
Network/TLS/Record/Types.hs view
@@ -13,30 +13,30 @@ -- 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+ ( 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
Network/TLS/Sending.hs view
@@ -8,7 +8,7 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state ---module Network.TLS.Sending (writePacket, encryptRSA) where+module Network.TLS.Sending (writePacket, encryptRSA, signRSA) where import Control.Applicative ((<$>)) import Control.Monad.State@@ -29,17 +29,9 @@ -} makeRecord :: Packet -> TLSSt (Record Plaintext) makeRecord pkt = do- ver <- stVersion <$> get- content <- writePacketContent pkt- return $ Record (packetType pkt) ver (fragmentPlaintext content)--{-- - Handshake data need to update a digest- -}-processRecord :: Record Plaintext -> TLSSt (Record Plaintext)-processRecord record@(Record ty _ fragment) = do- when (ty == ProtocolType_Handshake) (updateHandshakeDigest $ fragmentGetBytes fragment)- return record+ ver <- stVersion <$> get+ content <- writePacketContent pkt+ return $ Record (packetType pkt) ver (fragmentPlaintext content) {- - ChangeCipherSpec state change need to be handled after encryption otherwise@@ -48,7 +40,7 @@ -} postprocessRecord :: Record Ciphertext -> TLSSt (Record Ciphertext) postprocessRecord record@(Record ProtocolType_ChangeCipherSpec _ _) =- switchTxEncryption >> return record+ switchTxEncryption >> return record postprocessRecord record = return record {-@@ -56,7 +48,7 @@ -} encodeRecord :: Record Ciphertext -> TLSSt ByteString encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]- where (hdr, content) = recordToRaw record+ where (hdr, content) = recordToRaw record {- - just update TLS state machine@@ -66,9 +58,11 @@ preProcessPacket (AppData _) = return () preProcessPacket (ChangeCipherSpec) = return () preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do- case hs of- Finished fdata -> updateVerifiedData True fdata- _ -> return ()+ 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@@ -76,8 +70,8 @@ -} writePacket :: Packet -> TLSSt ByteString writePacket pkt = do- preProcessPacket pkt- makeRecord pkt >>= processRecord >>= engageRecord >>= postprocessRecord >>= encodeRecord+ preProcessPacket pkt+ makeRecord pkt >>= engageRecord >>= postprocessRecord >>= encodeRecord {------------------------------------------------------------------------------} {- SENDING Helpers -}@@ -88,11 +82,19 @@ -} encryptRSA :: ByteString -> TLSSt ByteString encryptRSA content = do- st <- get- let rsakey = fromJust "rsa public key" $ hstRSAPublicKey $ fromJust "handshake" $ stHandshake st- case withTLSRNG (stRandomGen st) (\g -> kxEncrypt g rsakey content) of- Left err -> fail ("rsa encrypt failed: " ++ show err)- Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent+ st <- get+ let rsakey = fromJust "rsa public key" $ hstRSAPublicKey $ fromJust "handshake" $ stHandshake st+ case withTLSRNG (stRandomGen st) (\g -> kxEncrypt g rsakey content) of+ Left err -> fail ("rsa encrypt failed: " ++ show err)+ Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent++signRSA :: (ByteString -> ByteString, ByteString) -> ByteString -> TLSSt ByteString+signRSA hsh content = do+ st <- get+ let rsakey = fromJust "rsa client private key" $ hstRSAClientPrivateKey $ fromJust "handshake" $ stHandshake st+ case kxSign rsakey hsh content of+ Left err -> fail ("rsa sign failed: " ++ show err)+ Right econtent -> return econtent writePacketContent :: Packet -> TLSSt ByteString writePacketContent (Handshake hss) = return $ encodeHandshakes hss
+ Network/TLS/Session.hs view
@@ -0,0 +1,30 @@+-- |+-- Module : Network.TLS.Session+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 ()
Network/TLS/State.hs view
@@ -10,46 +10,69 @@ -- 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- , makeDigest- , setMasterSecret- , setMasterSecretFromPre- , setPublicKey- , setPrivateKey- , setKeyBlock- , setVersion- , setCipher- , setServerRandom- , setSecureRenegotiation- , getSecureRenegotiation- , getVerifiedData- , setSession- , getSession- , getSessionData- , needEmptyPacket- , isSessionResuming- , switchTxEncryption- , switchRxEncryption- , getCipherKeyExchangeType- , isClientContext- , startHandshakeClient- , updateHandshakeDigest- , getHandshakeDigest- , endHandshake- ) where+ ( 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)@@ -67,67 +90,87 @@ import Control.Monad.State import Control.Monad.Error import Crypto.Random+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")+ when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") data TLSCryptState = TLSCryptState- { cstKey :: !Bytes- , cstIV :: !Bytes- , cstMacSecret :: !Bytes- } deriving (Show)+ { cstKey :: !Bytes+ , cstIV :: !Bytes+ , cstMacSecret :: !Bytes+ } deriving (Show) data TLSMacState = TLSMacState- { msSequence :: Word64- } deriving (Show)+ { 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)- , hstHandshakeDigest :: !HashCtx- } deriving (Show)+ { 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 . CryptoRandomGen g => StateRNG g instance Show StateRNG where- show _ = "rng[..]"+ show _ = "rng[..]" data TLSState = TLSState- { stClientContext :: Bool- , stVersion :: !Version- , stHandshake :: !(Maybe TLSHandshakeState)- , stSession :: Session- , stSessionResuming :: Bool- , stTxEncrypted :: Bool- , stRxEncrypted :: Bool- , stTxCryptState :: !(Maybe TLSCryptState)- , stRxCryptState :: !(Maybe TLSCryptState)- , stTxMacState :: !(Maybe TLSMacState)- , stRxMacState :: !(Maybe TLSMacState)- , stCipher :: Maybe Cipher- , stCompression :: Compression- , stRandomGen :: StateRNG- , stSecureRenegotiation :: Bool -- RFC 5746- , stClientVerifiedData :: Bytes -- RFC 5746- , stServerVerifiedData :: Bytes -- RFC 5746- } deriving (Show)+ { 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)+ , stCipher :: 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)+ deriving (Monad, MonadError TLSError) instance Functor TLSSt where- fmap f = TLSSt . fmap f . runTLSSt+ fmap f = TLSSt . fmap f . runTLSSt instance MonadState TLSState TLSSt where- put x = TLSSt (lift $ put x)- get = TLSSt (lift get)+ put x = TLSSt (lift $ put x)+ get = TLSSt (lift get) #if MIN_VERSION_mtl(2,1,0)- state f = TLSSt (lift $ state f)+ state f = TLSSt (lift $ state f) #endif runTLSState :: TLSSt a -> TLSState -> (Either TLSError a, TLSState)@@ -135,70 +178,78 @@ newTLSState :: CryptoRandomGen g => g -> TLSState newTLSState rng = TLSState- { stClientContext = False- , stVersion = TLS10- , stHandshake = Nothing- , stSession = Session Nothing- , stSessionResuming = False- , stTxEncrypted = False- , stRxEncrypted = False- , stTxCryptState = Nothing- , stRxCryptState = Nothing- , stTxMacState = Nothing- , stRxMacState = Nothing- , stCipher = Nothing- , stCompression = nullCompression- , stRandomGen = StateRNG rng- , stSecureRenegotiation = False- , stClientVerifiedData = B.empty- , stServerVerifiedData = B.empty- }+ { 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+ , stCipher = 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 . CryptoRandomGen g => g -> Either e (a,g)) -> Either e (a, StateRNG) withTLSRNG (StateRNG rng) f = case f rng of- Left err -> Left err- Right (a, rng') -> Right (a, StateRNG rng')+ Left err -> Left err+ Right (a, rng') -> Right (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+ 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) (genBytes n) of- Left err -> throwError $ Error_Random $ show err- Right (bytes, rng') -> put (st { stRandomGen = rng' }) >> return bytes+ st <- get+ case withTLSRNG (stRandomGen st) (genBytes n) of+ Left err -> throwError $ Error_Random $ show err+ Right (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 stTxCryptState st else stRxCryptState st- let ms = fromJust "mac state" $ if w then stTxMacState st else stRxMacState st- let cipher = fromJust "cipher" $ stCipher st- let hashf = hashF $ cipherHash cipher+ 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" $ stCipher 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 (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 }+ let newms = ms { msSequence = (msSequence ms) + 1 } - modify (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })- return digest+ 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 })+ cc <- isClientContext+ if cc /= sending+ then modify (\st -> st { stServerVerifiedData = bs })+ else modify (\st -> st { stClientVerifiedData = bs }) finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello = True@@ -209,56 +260,120 @@ finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True finishHandshakeTypeMaterial HandshakeType_CertRequest = True-finishHandshakeTypeMaterial HandshakeType_CertVerify = False+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 })-switchRxEncryption = modify (\st -> st { stRxEncrypted = True })+switchTxEncryption = modify (\st -> st { stTxEncrypted = True,+ stActiveTxMacState = stPendingTxMacState st,+ stActiveTxCryptState = stPendingTxCryptState st })+switchRxEncryption = modify (\st -> st { stRxEncrypted = True,+ stActiveRxMacState = stPendingRxMacState st,+ stActiveRxCryptState = stPendingRxCryptState 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"+ hasValidHandshake "master secret" - updateHandshake "master secret" (\hst -> hst { hstMasterSecret = Just masterSecret } )- setKeyBlock- return ()+ 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)+ 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 = do+ st <- get+ return (stHandshake st >>= 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 = do+ st <- get+ return (stHandshake st >>= 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 = do+ st <- get+ return (stHandshake st >>= 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 = do+ st <- get+ return (stHandshake st >>= 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 = do+ st <- get+ return (stHandshake st >>= hstClientCertRequest)+ getSessionData :: MonadState TLSState m => m (Maybe SessionData) getSessionData = do- st <- get- return (stHandshake st >>= hstMasterSecret >>= wrapSessionData st)- where wrapSessionData st masterSecret = do- return $ SessionData- { sessionVersion = stVersion st- , sessionCipher = cipherID $ fromJust "cipher" $ stCipher st- , sessionSecret = masterSecret- }+ st <- get+ return (stHandshake st >>= hstMasterSecret >>= wrapSessionData st)+ where wrapSessionData st masterSecret = do+ return $ SessionData+ { sessionVersion = stVersion st+ , sessionCipher = cipherID $ fromJust "cipher" $ stCipher st+ , sessionSecret = masterSecret+ } setSession :: MonadState TLSState m => Session -> Bool -> m () setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming })@@ -276,41 +391,41 @@ setKeyBlock :: MonadState TLSState m => m () setKeyBlock = do- st <- get+ st <- get - let hst = fromJust "handshake" $ stHandshake st+ let hst = fromJust "handshake" $ stHandshake st - let cc = stClientContext st- let cipher = fromJust "cipher" $ stCipher st- let keyblockSize = cipherKeyBlockSize cipher+ let cc = stClientContext st+ let cipher = fromJust "cipher" $ stCipher st+ let keyblockSize = cipherKeyBlockSize cipher - let bulk = cipherBulk cipher- let digestSize = hashSize $ cipherHash cipher- let keySize = bulkKeySize bulk- let ivSize = bulkIVSize bulk- let kb = generateKeyBlock (stVersion st) (hstClientRandom hst)- (fromJust "server random" $ hstServerRandom hst)- (fromJust "master secret" $ hstMasterSecret hst) keyblockSize+ let bulk = cipherBulk cipher+ let digestSize = hashSize $ cipherHash cipher+ let keySize = bulkKeySize bulk+ let ivSize = bulkIVSize bulk+ let kb = generateKeyBlock (stVersion st) (hstClientRandom hst)+ (fromJust "server random" $ hstServerRandom hst)+ (fromJust "master secret" $ hstMasterSecret hst) keyblockSize - let (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =- fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize)+ let (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =+ fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) - let cstClient = TLSCryptState- { cstKey = cWriteKey- , cstIV = cWriteIV- , cstMacSecret = cMACSecret }- let cstServer = TLSCryptState- { cstKey = sWriteKey- , cstIV = sWriteIV- , cstMacSecret = sMACSecret }- let msClient = TLSMacState { msSequence = 0 }- let msServer = TLSMacState { msSequence = 0 }- put $ st- { stTxCryptState = Just $ if cc then cstClient else cstServer- , stRxCryptState = Just $ if cc then cstServer else cstClient- , stTxMacState = Just $ if cc then msClient else msServer- , stRxMacState = Just $ if cc then msServer else msClient- }+ let cstClient = TLSCryptState+ { cstKey = cWriteKey+ , cstIV = cWriteIV+ , cstMacSecret = cMACSecret }+ let cstServer = TLSCryptState+ { cstKey = sWriteKey+ , cstIV = sWriteIV+ , cstMacSecret = sMACSecret }+ let msClient = TLSMacState { msSequence = 0 }+ let msServer = TLSMacState { msSequence = 0 }+ put $ 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+ } setCipher :: MonadState TLSState m => Cipher -> m () setCipher cipher = modify (\st -> st { stCipher = Just cipher })@@ -324,6 +439,30 @@ getSecureRenegotiation :: MonadState TLSState m => m Bool getSecureRenegotiation = get >>= return . stSecureRenegotiation +setExtensionNPN :: MonadState TLSState m => Bool -> m ()+setExtensionNPN b = modify (\st -> st { stExtensionNPN = b })++getExtensionNPN :: MonadState TLSState m => m Bool+getExtensionNPN = get >>= return . 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 = get >>= return . 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 = get >>= return . stClientCertificateChain+ getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType) getCipherKeyExchangeType = get >>= return . (maybe Nothing (Just . cipherKeyExchange) . stCipher) @@ -336,42 +475,59 @@ -- 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- , hstHandshakeDigest = digestInit- }+ { 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 })+ -- 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 })+ 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 }+ 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+ 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 })
Network/TLS/Struct.hs view
@@ -10,150 +10,149 @@ -- the Struct module contains all definitions and values of the TLS protocol -- module Network.TLS.Struct- ( Bytes- , Version(..)- , ConnectionEnd(..)- , CipherType(..)- , CipherData(..)- , Extension- , CertificateType(..)- , HashAlgorithm(..)- , SignatureAlgorithm(..)- , ProtocolType(..)- , TLSError(..)- , ServerDHParams(..)- , ServerRSAParams(..)- , ServerKeyXchgAlgorithmData(..)- , Packet(..)- , Header(..)- , ServerRandom(..)- , ClientRandom(..)- , serverRandom- , clientRandom- , FinishedData- , SessionID- , Session(..)- , SessionData(..)- , AlertLevel(..)- , AlertDescription(..)- , HandshakeType(..)- , Handshake(..)- , numericalVer- , verOfNum- , TypeValuable, valOfType, valToType- , packetType- , typeOfHandshake- ) where+ ( 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 --- | 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) data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD data CipherData = CipherData- { cipherDataContent :: Bytes- , cipherDataMAC :: Maybe Bytes- , cipherDataPadding :: Maybe Bytes- } deriving (Show,Eq)+ { 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)+ 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)+ HashNone+ | HashMD5+ | HashSHA1+ | HashSHA224+ | HashSHA256+ | HashSHA384+ | HashSHA512+ | HashOther Word8+ deriving (Show,Eq) data SignatureAlgorithm =- SignatureAnonymous- | SignatureRSA- | SignatureDSS- | SignatureECDSA- | SignatureOther Word8- deriving (Show,Eq)+ SignatureAnonymous+ | SignatureRSA+ | SignatureDSS+ | SignatureECDSA+ | SignatureOther Word8+ deriving (Show,Eq) +type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm)+ data ProtocolType =- ProtocolType_ChangeCipherSpec- | ProtocolType_Alert- | ProtocolType_Handshake- | ProtocolType_AppData- deriving (Eq, Show)+ ProtocolType_ChangeCipherSpec+ | ProtocolType_Alert+ | ProtocolType_Handshake+ | ProtocolType_AppData+ 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_Random String- | Error_EOF- | Error_Packet String- | Error_Packet_Size_Mismatch (Int, Int)- | Error_Packet_unexpected String String- | Error_Packet_Parsing String- | Error_Internal_Packet_ByteProcessed Int Int Int- | Error_Unknown_Version Word8 Word8- | Error_Unknown_Type String- deriving (Eq, Show, Typeable)+ Error_Misc String -- ^ mainly for instance of Error+ | Error_Protocol (String, Bool, AlertDescription)+ | Error_Certificate String+ | Error_HandshakePolicy String -- ^ handshake policy failed.+ | Error_Random String+ | Error_EOF+ | Error_Packet String+ | Error_Packet_Size_Mismatch (Int, Int)+ | Error_Packet_unexpected String String+ | Error_Packet_Parsing String+ | Error_Internal_Packet_ByteProcessed Int Int Int+ | Error_Unknown_Version Word8 Word8+ | Error_Unknown_Type String+ deriving (Eq, Show, Typeable) instance Error TLSError where- noMsg = Error_Misc ""- strMsg = Error_Misc+ noMsg = Error_Misc ""+ strMsg = Error_Misc instance Exception TLSError data Packet =- Handshake [Handshake]- | Alert [(AlertLevel, AlertDescription)]- | ChangeCipherSpec- | AppData ByteString- deriving (Show,Eq)+ 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)-type SessionID = Bytes newtype Session = Session (Maybe SessionID) deriving (Show, Eq) -data SessionData = SessionData- { sessionVersion :: Version- , sessionCipher :: CipherID- , sessionSecret :: Bytes- }--type CipherID = Word16-type CompressionID = Word8 type FinishedData = Bytes-type Extension = (Word16, 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 @@ -164,82 +163,89 @@ clientRandom l = constrRandom32 ClientRandom l data AlertLevel =- AlertLevel_Warning- | AlertLevel_Fatal- deriving (Show,Eq)+ 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- deriving (Show,Eq)+ 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- deriving (Show,Eq)+ 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)+ { 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)+ { 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)+ 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) data Handshake =- ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [Extension]- | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [Extension]- | Certificates [X509]- | HelloRequest- | ServerHelloDone- | ClientKeyXchg Bytes- | ServerKeyXchg ServerKeyXchgAlgorithmData- | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8]- | CertVerify [Word8]- | Finished FinishedData- deriving (Show,Eq)+ ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw]+ | 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@@ -248,16 +254,17 @@ 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 (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)@@ -275,168 +282,180 @@ verOfNum _ = Nothing class TypeValuable a where- valOfType :: a -> Word8- valToType :: Word8 -> Maybe a+ valOfType :: a -> Word8+ valToType :: Word8 -> Maybe a instance TypeValuable ConnectionEnd where- valOfType ConnectionServer = 0- valOfType ConnectionClient = 1+ valOfType ConnectionServer = 0+ valOfType ConnectionClient = 1 - valToType 0 = Just ConnectionServer- valToType 1 = Just ConnectionClient- valToType _ = Nothing+ valToType 0 = Just ConnectionServer+ valToType 1 = Just ConnectionClient+ valToType _ = Nothing instance TypeValuable CipherType where- valOfType CipherStream = 0- valOfType CipherBlock = 1- valOfType CipherAEAD = 2+ valOfType CipherStream = 0+ valOfType CipherBlock = 1+ valOfType CipherAEAD = 2 - valToType 0 = Just CipherStream- valToType 1 = Just CipherBlock- valToType 2 = Just CipherAEAD- valToType _ = Nothing+ 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_ChangeCipherSpec = 20+ valOfType ProtocolType_Alert = 21+ valOfType ProtocolType_Handshake = 22+ valOfType ProtocolType_AppData = 23 - valToType 20 = Just ProtocolType_ChangeCipherSpec- valToType 21 = Just ProtocolType_Alert- valToType 22 = Just ProtocolType_Handshake- valToType 23 = Just ProtocolType_AppData- valToType _ = Nothing+ 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_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 _ = Nothing+ 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+ valOfType AlertLevel_Warning = 1+ valOfType AlertLevel_Fatal = 2 - valToType 1 = Just AlertLevel_Warning- valToType 2 = Just AlertLevel_Fatal- valToType _ = Nothing+ 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 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 _ = Nothing+ 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+ 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)+ 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+ 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)+ 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+ 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)+ valToType 0 = Just SignatureAnonymous+ valToType 1 = Just SignatureRSA+ valToType 2 = Just SignatureDSS+ valToType 3 = Just SignatureECDSA+ valToType i = Just (SignatureOther i)
+ Network/TLS/Types.hs view
@@ -0,0 +1,38 @@+-- |+-- Module : Network.TLS.Types+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
Network/TLS/Util.hs view
@@ -1,13 +1,13 @@ module Network.TLS.Util- ( sub- , takelast- , partition3- , partition6- , fromJust- , and'- , (&&!)- , bytesEq- ) where+ ( sub+ , takelast+ , partition3+ , partition6+ , fromJust+ , and'+ , (&&!)+ , bytesEq+ ) where import Data.List (foldl') import Network.TLS.Struct (Bytes)@@ -15,32 +15,35 @@ 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+ | 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+ | 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) = if B.length bytes /= s then Nothing else Just (p1,p2,p3)- where- s = sum [d1,d2,d3]- (p1, r1) = B.splitAt d1 bytes- (p2, r2) = B.splitAt d2 r1- (p3, _) = B.splitAt d3 r2+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+ 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@@ -59,6 +62,8 @@ -- | verify that 2 bytestrings are equals. -- it's a non lazy version, that will compare every bytes.--- arguments need to be of same length+-- arguments with different length will bail out early bytesEq :: Bytes -> Bytes -> Bool-bytesEq b1 = and' . B.zipWith (==) b1+bytesEq b1 b2+ | B.length b1 /= B.length b2 = False+ | otherwise = and' $ B.zipWith (==) b1 b2
Network/TLS/Wire.hs view
@@ -9,34 +9,37 @@ -- all multibytes values are written as big endian. -- module Network.TLS.Wire- ( Get- , runGet- , remaining- , getWord8- , getWords8- , getWord16- , getWords16- , getWord24- , getBytes- , getOpaque8- , getOpaque16- , getOpaque24- , processBytes- , isEmpty- , Put- , runPut- , putWord8- , putWords8- , putWord16- , putWords16- , putWord24- , putBytes- , putOpaque8- , putOpaque16- , putOpaque24- , encodeWord16- , encodeWord64- ) where+ ( 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@@ -51,6 +54,12 @@ 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 @@ -62,10 +71,10 @@ getWord24 :: Get Int getWord24 = do- a <- fromIntegral <$> getWord8- b <- fromIntegral <$> getWord8- c <- fromIntegral <$> getWord8- return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c+ a <- fromIntegral <$> getWord8+ b <- fromIntegral <$> getWord8+ c <- fromIntegral <$> getWord8+ return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c getOpaque8 :: Get Bytes getOpaque8 = getWord8 >>= getBytes . fromIntegral@@ -76,28 +85,35 @@ 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+ 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+ 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]+ 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
− README.md
@@ -1,45 +0,0 @@-haskell TLS-===========--This library provide native Haskell TLS and SSL protocol implementation for server and client.--Description--------------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.--Only core protocol available here, have a look at the tls-extra package for-default ciphers, compressions and certificates functions.--Features-----------* tiny code base (more than 20 times smaller than openSSL, and 10 times smaller than gnuTLS)-* permissive license: BSD3.-* supported versions: SSL3, TLS1.0, TLS1.1, TLS1.2.-* key exchange supported: only RSA.-* bulk algorithm supported: any stream or block ciphers.-* supported extensions: secure renegociation--Common Issues----------------The tools mentioned below are all available from the tls-debug package.--* Certificate issues--It's useful to run the following command, which will connect to the destination and-retrieve the certificate chained used.-- tls-retrievecertificate -d <destination> -p <port> -v -c--As an output it will print every certificates in the chain and will gives the issuer and subjects of each.-It creates a chain where issuer of certificate is the subject of the next certificate part of the chain:-- (subject #1, issuer #2) -> (subject #2, issuer #3) -> (subject #3, issuer #3)--A "CA is unknown" error indicates that your system doesn't have a certificate in-the trusted store belonging to any of the node of the chain.-
− TODO
@@ -1,27 +0,0 @@-protocol:--- implement Certificate Verify / Certificate Request-- add Client Certificates-- process session as they should-- put 4 bytes of time in client/server random-- proper separation for key exchange algorithm (hardcoded to RSA at the moment in differents place)-- implements different key exchange algorithm-- implement AEAD bulk algorithm (TLS1.2)--code cleanup:--- remove show derivation on internal crypto state-- opaquify differents data type through newtype--security audit:--- add more unit tests for pure parts-- match security recommendation from the RFC--misc:--- investigate an iteratee/enumerator interface-- portability-- implement more ciphers-- check & optimize memory footprint-- compare & optimize performance
Tests.hs view
@@ -13,58 +13,61 @@ 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.Core-import Network.TLS.Cipher+import Network.TLS import Network.TLS.Struct import Network.TLS.Packet import Control.Applicative import Control.Concurrent-import Control.Exception (throw, catch, SomeException)+import Control.Exception (throw, SomeException)+import qualified Control.Exception as E import Control.Monad import Data.IORef -import Prelude hiding (catch)- genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i instance Arbitrary Version where- arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ]+ arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ] instance Arbitrary ProtocolType where- arbitrary = elements- [ ProtocolType_ChangeCipherSpec- , ProtocolType_Alert- , ProtocolType_Handshake- , ProtocolType_AppData ]+ 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)+ arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int) instance Arbitrary Word16 where- arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int)+ arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int) #endif instance Arbitrary Header where- arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary+ arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ClientRandom where- arbitrary = ClientRandom <$> (genByteString 32)+ arbitrary = ClientRandom <$> (genByteString 32) instance Arbitrary ServerRandom where- arbitrary = ServerRandom <$> (genByteString 32)+ 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+ 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 @@ -75,37 +78,37 @@ 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 ]+ 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 [])- , 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 [])- --, liftM CertVerify (return [])- , Finished <$> (genByteString 12)- ]+ arbitrary = oneof+ [ ClientHello+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitraryCiphersIDs+ <*> arbitraryCompressionIDs+ <*> (return [])+ , 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 -} @@ -114,167 +117,214 @@ 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 }+ 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)+ pipe <- run newPipe+ _ <- run (runPipe pipe) - let bSize = 16- n <- pick (choose (1, 32))+ let bSize = 16+ n <- pick (choose (1, 32)) - let d1 = B.replicate (bSize * n) 40- let d2 = B.replicate (bSize * n) 45+ 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'+ 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'+ d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2))+ d2 `assertEq` d2' - return ()+ return () establish_data_pipe params tlsServer tlsClient = do- -- initial setup- pipe <- newPipe- _ <- (runPipe pipe)- startQueue <- newChan- resultQueue <- newChan+ -- initial setup+ pipe <- newPipe+ _ <- (runPipe pipe)+ startQueue <- newChan+ resultQueue <- newChan - (cCtx, sCtx) <- newPairContext pipe params+ (cCtx, sCtx) <- newPairContext pipe params - _ <- forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server")- _ <- forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client")+ _ <- 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+ return (startQueue, resultQueue)+ where+ printAndRaise :: String -> SomeException -> IO ()+ printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e -recvDataNonNull ctx = recvData' ctx >>= \l -> if L.null l then recvDataNonNull ctx else return l+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)+ 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 <- L.pack <$> pick (someWords8 256)- run $ writeChan startQueue d+ {- 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+ 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 d- bye ctx- return ()+ 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)+ 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 <- L.pack <$> pick (someWords8 256)- run $ writeChan startQueue d+ {- 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+ 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 d- bye ctx- return ()+ 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+ sessionRef <- run $ newIORef Nothing+ let sessionManager = OneSessionManager sessionRef - plainParams <- pick arbitraryPairParams- let params = setPairParamsSessionSaving (\sid d -> writeIORef sessionRef $ Just (sid,d)) plainParams+ plainParams <- pick arbitraryPairParams+ let params = setPairParamsSessionManager sessionManager plainParams - -- establish a session.- (s1, r1) <- run (establish_data_pipe params tlsServer tlsClient)+ -- establish a session.+ (s1, r1) <- run (establish_data_pipe params tlsServer tlsClient) - d <- L.pack <$> pick (someWords8 256)- run $ writeChan s1 d- dres <- run $ readChan r1- d `assertEq` dres+ 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) plainParams+ -- 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)+ -- 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 <- L.pack <$> pick (someWords8 256)- run $ writeChan startQueue d2+ {- 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+ 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 d- bye ctx- return ()+ 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- ]+ [ 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 "renegociation" (monadicIO prop_handshake_renegociation)- , testProperty "resumption" (monadicIO prop_handshake_session_resumption)- ]+ -- 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)+ ]
+ Tests/Certificate.hs view
@@ -0,0 +1,57 @@+module Tests.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 Tests.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
+ Tests/Connection.hs view
@@ -0,0 +1,123 @@+module Tests.Connection+ ( newPairContext+ , arbitraryPairParams+ , setPairParamsSessionManager+ , setPairParamsSessionResuming+ ) where++import Test.QuickCheck+import Tests.Certificate+import Tests.PubKey+import Tests.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))+ }+ }++nullCipher = blockCipher+ { cipherID = 0xff14+ , cipherBulk = Bulk+ { bulkName = "null"+ , bulkKeySize = 0+ , bulkIVSize = 0+ , bulkBlockSize = 0+ , bulkF = BulkNoneF+ }+ }++supportedCiphers :: [Cipher]+supportedCiphers = [blockCipher,streamCipher,nullCipher]++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')
+ Tests/PipeChan.hs view
@@ -0,0 +1,56 @@+-- create a similar concept than a unix pipe.+module Tests.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)
+ Tests/PubKey.hs view
@@ -0,0 +1,32 @@+module Tests.PubKey+ ( arbitraryRSAPair+ , globalRSAPair+ , getGlobalRSAPair+ ) where++import Test.QuickCheck++import qualified Crypto.Random.AESCtr as RNG+import qualified Crypto.Cipher.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 <- (either (error . show) id . RNG.make . B.pack) `fmap` vector 64+ arbitraryRSAPairWithRNG rng++arbitraryRSAPairWithRNG rng = case RSA.generate rng 128 65537 of+ Left _ -> error "couldn't generate RSA"+ Right (keypair, _) -> return keypair++{-# 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.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.9.11+Version: 1.0.0 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -22,9 +22,9 @@ Build-Type: Simple Category: Network stability: experimental-Cabal-Version: >=1.6+Cabal-Version: >=1.8 Homepage: http://github.com/vincenthz/hs-tls-data-files: README.md, TODO+extra-source-files: Tests/*.hs Flag test Description: Build unit test@@ -40,9 +40,10 @@ , cryptohash >= 0.6 , cereal >= 0.3 , bytestring+ , network , crypto-api >= 0.5 , cryptocipher >= 0.3.0 && < 0.4.0- , certificate >= 1.2.0 && < 1.3.0+ , certificate >= 1.3.0 && < 1.4.0 Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression@@ -52,6 +53,14 @@ 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@@ -60,9 +69,11 @@ 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)@@ -73,13 +84,19 @@ if flag(test) Buildable: True Build-Depends: base >= 3 && < 5+ , mtl+ , cereal >= 0.3 , QuickCheck >= 2 , test-framework , test-framework-quickcheck2 , bytestring , time+ , cryptocipher >= 0.3.0 && < 0.4.0+ , network , cprng-aes- , cryptocipher >= 0.3.0+ , cryptohash >= 0.6+ , certificate >= 1.3.0 && < 1.4.0+ , crypto-api >= 0.5 else Buildable: False ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fhpc