diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2011 Vincent Hanquez +Copyright (c) 2010-2012 Vincent Hanquez All rights reserved. diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -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 diff --git a/Network/TLS/Cap.hs b/Network/TLS/Cap.hs --- a/Network/TLS/Cap.hs +++ b/Network/TLS/Cap.hs @@ -7,9 +7,9 @@ -- module Network.TLS.Cap - ( hasHelloExtensions - , hasExplicitBlockIV - ) where + ( hasHelloExtensions + , hasExplicitBlockIV + ) where import Network.TLS.Struct diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -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 diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs --- a/Network/TLS/Compression.hs +++ b/Network/TLS/Compression.hs @@ -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 diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -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) - diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 . (:[]) diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -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 diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extension.hs @@ -0,0 +1,134 @@ +-- | +-- Module : Network.TLS.Extension +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- basic extensions are defined in RFC 6066 +-- +module Network.TLS.Extension + ( Extension(..) + , supportedExtensions + -- all extensions ID supported + , extensionID_ServerName + , extensionID_MaxFragmentLength + , extensionID_SecureRenegotiation + , extensionID_NextProtocolNegotiation + -- all implemented extensions + , ServerNameType(..) + , ServerName(..) + , MaxFragmentLength(..) + , MaxFragmentEnum(..) + , SecureRenegotiation(..) + , NextProtocolNegotiation(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Monad + +import Data.Word +import Data.Maybe (fromMaybe) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +import Network.TLS.Struct (ExtensionID) +import Network.TLS.Wire +import Network.BSD (HostName) + +extensionID_ServerName, extensionID_MaxFragmentLength + , extensionID_SecureRenegotiation + , extensionID_NextProtocolNegotiation :: ExtensionID +extensionID_ServerName = 0x0 +extensionID_MaxFragmentLength = 0x1 +extensionID_SecureRenegotiation = 0xff01 +extensionID_NextProtocolNegotiation = 0x3374 + +-- | all supported extensions by the implementation +supportedExtensions :: [ExtensionID] +supportedExtensions = [ extensionID_ServerName + , extensionID_MaxFragmentLength + , extensionID_SecureRenegotiation + , extensionID_NextProtocolNegotiation + ] + +-- | Extension class to transform bytes to and from a high level Extension type. +class Extension a where + extensionID :: a -> ExtensionID + extensionDecode :: Bool -> ByteString -> Maybe a + extensionEncode :: a -> ByteString + +-- | Server Name extension including the name type and the associated name. +-- the associated name decoding is dependant of its name type. +-- name type = 0 : hostname +data ServerName = ServerName [ServerNameType] + deriving (Show,Eq) + +data ServerNameType = ServerNameHostName HostName + | ServerNameOther (Word8, ByteString) + deriving (Show,Eq) + +instance Extension ServerName where + extensionID _ = extensionID_ServerName + extensionEncode (ServerName l) = runPut $ 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 diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +-- | +-- Module : Network.TLS.Handshake +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake + ( handshake + , handshakeServerWith + , handshakeClient + , HandshakeFailed(..) + ) where + +import Network.TLS.Context +import Network.TLS.Struct +import Network.TLS.IO + +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Client +import Network.TLS.Handshake.Server + +import Control.Monad.State +import Control.Exception (fromException) +import qualified Control.Exception as E + +-- | Handshake for a new TLS connection +-- This is to be called at the beginning of a connection, and during renegotiation +handshake :: MonadIO m => Context -> m () +handshake ctx = do + let handshakeF = case roleParams $ ctxParams ctx of + Server sparams -> handshakeServer sparams + Client cparams -> handshakeClient cparams + liftIO $ handleException $ handshakeF ctx + where + handleException f = E.catch f $ \exception -> do + let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception + setEstablished ctx False + sendPacket ctx (errorToAlert tlserror) + handshakeFailed tlserror diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Certificate.hs @@ -0,0 +1,30 @@ +-- | +-- Module : Network.TLS.Handshake.Certificate +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake.Certificate + ( certificateRejected + , rejectOnException + ) where + +import Network.TLS.Context +import Network.TLS.Struct +import Control.Monad.State +import Control.Exception (SomeException) + +-- on certificate reject, throw an exception with the proper protocol alert error. +certificateRejected :: MonadIO m => CertificateRejectReason -> m a +certificateRejected CertificateRejectRevoked = + throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked) +certificateRejected CertificateRejectExpired = + throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired) +certificateRejected CertificateRejectUnknownCA = + throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa) +certificateRejected (CertificateRejectOther s) = + throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) + +rejectOnException :: SomeException -> IO TLSCertificateUsage +rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +-- | +-- Module : Network.TLS.Handshake.Client +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake.Client + ( handshakeClient + ) where + +import Network.TLS.Crypto +import Network.TLS.Context +import Network.TLS.Struct +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Packet +import Network.TLS.Extension +import Network.TLS.IO +import Network.TLS.State hiding (getNegotiatedProtocol) +import Network.TLS.Sending +import Network.TLS.Receiving +import Network.TLS.Measurement +import Network.TLS.Wire (encodeWord16) +import Data.Maybe +import Data.List (find) +import qualified Data.ByteString as B +import Data.ByteString.Char8 () + +import Data.Certificate.X509(X509, x509Cert, certPubKey, PubKey(PubKeyRSA)) + +import Control.Applicative ((<$>)) +import Control.Monad.State +import Control.Exception (SomeException) +import qualified Control.Exception as E + +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Certificate +import Network.TLS.Handshake.Signature + +-- client part of handshake. send a bunch of handshake of client +-- values intertwined with response from the server. +handshakeClient :: MonadIO m => ClientParams -> Context -> m () +handshakeClient cparams ctx = do + updateMeasure ctx incrementNbHandshakes + sentExtensions <- sendClientHello + recvServerHello sentExtensions + sessionResuming <- usingState_ ctx isSessionResuming + if sessionResuming + then sendChangeCipherAndFinish ctx True + else do sendClientData cparams ctx + sendChangeCipherAndFinish ctx True + recvChangeCipherAndFinish ctx + handshakeTerminate ctx + where + params = ctxParams ctx + allowedvers = pAllowedVersions params + ciphers = pCiphers params + compressions = pCompressions params + getExtensions = sequence [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 diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Common.hs @@ -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 + diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +-- | +-- Module : Network.TLS.Handshake.Server +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake.Server + ( handshakeServer + , handshakeServerWith + ) where + +import Network.TLS.Crypto +import Network.TLS.Context +import Network.TLS.Session +import Network.TLS.Struct +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Packet +import Network.TLS.Extension +import Network.TLS.IO +import Network.TLS.State hiding (getNegotiatedProtocol) +import Network.TLS.Receiving +import Network.TLS.Measurement +import Data.Maybe +import Data.List (intersect) +import qualified Data.ByteString as B +import Data.ByteString.Char8 () + +import Data.Certificate.X509(X509, certSubjectDN, x509Cert) + +import Control.Applicative ((<$>)) +import Control.Monad.State +import qualified Control.Exception as E + +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Certificate + +-- Put the server context in handshake mode. +-- +-- Expect to receive as first packet a client hello handshake message +-- +-- This is just a helper to pop the next message from the recv layer, +-- and call handshakeServerWith. +handshakeServer :: MonadIO m => ServerParams -> Context -> m () +handshakeServer sparams ctx = do + hss <- recvPacketHandshake ctx + case hss of + [ch] -> handshakeServerWith sparams ctx ch + _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss) + +-- | Put the server context in handshake mode. +-- +-- Expect a client hello message as parameter. +-- This is useful when the client hello has been already poped from the recv layer to inspect the packet. +-- +-- When the function returns, a new handshake has been succesfully negociated. +-- On any error, a HandshakeFailed exception is raised. +-- +-- handshake protocol (<- receiving, -> sending, [] optional): +-- (no session) (session resumption) +-- <- client hello <- client hello +-- -> server hello -> server hello +-- -> [certificate] +-- -> [server key xchg] +-- -> [cert request] +-- -> hello done +-- <- [certificate] +-- <- client key xchg +-- <- [cert verify] +-- <- change cipher -> change cipher +-- <- [NPN] +-- <- finish -> finish +-- -> change cipher <- change cipher +-- -> finish <- finish +-- +handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m () +handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts) = do + -- check if policy allow this new handshake to happens + handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx) + unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") + updateMeasure ctx incrementNbHandshakes + + -- Handle Client hello + usingState_ ctx $ processHandshake clientHello + when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) + when (not $ elem ver (pAllowedVersions params)) $ + throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) + when (commonCipherIDs == []) $ + throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) + when (null commonCompressions) $ + throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) + usingState_ ctx $ modify (\st -> st + { stVersion = ver + , 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") diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Signature.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.TLS.Handshake.Signature +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake.Signature + ( getHashAndASN1 + ) where + +import 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" + + diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/IO.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Network.TLS.IO +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.IO + ( checkValid + , ConnectionNotEstablished(..) + , sendPacket + , recvPacket + ) where + +import Network.TLS.Context +import Network.TLS.State (needEmptyPacket) +import Network.TLS.Struct +import Network.TLS.Record +import Network.TLS.Packet +import Network.TLS.Sending +import Network.TLS.Receiving +import Data.Data +import qualified Data.ByteString as B +import Data.ByteString.Char8 () + +import Control.Monad.State +import Control.Exception (throwIO, Exception()) +import System.IO.Error (mkIOError, eofErrorType) + +data ConnectionNotEstablished = ConnectionNotEstablished + deriving (Show,Eq,Typeable) + +instance Exception ConnectionNotEstablished + +checkValid :: MonadIO m => Context -> m () +checkValid ctx = do + established <- ctxEstablished ctx + unless established $ liftIO $ throwIO ConnectionNotEstablished + eofed <- ctxEOF ctx + when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing + +readExact :: MonadIO m => Context -> Int -> m Bytes +readExact ctx sz = do + hdrbs <- liftIO $ contextRecv ctx sz + when (B.length hdrbs < sz) $ do + setEOF ctx + if B.null hdrbs + then throwCore Error_EOF + else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) + return hdrbs + +recvRecord :: MonadIO m => 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 diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -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 diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -1,14 +1,21 @@ +-- | +-- Module : Network.TLS.MAC +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- module Network.TLS.MAC - ( hmacMD5 - , hmacSHA1 - , hmacSHA256 - , macSSL - , hmac - , prf_MD5 - , prf_SHA1 - , prf_SHA256 - , prf_MD5SHA1 - ) where + ( 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 diff --git a/Network/TLS/Measurement.hs b/Network/TLS/Measurement.hs --- a/Network/TLS/Measurement.hs +++ b/Network/TLS/Measurement.hs @@ -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 } diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -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 "" diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -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 () diff --git a/Network/TLS/Record.hs b/Network/TLS/Record.hs --- a/Network/TLS/Record.hs +++ b/Network/TLS/Record.hs @@ -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 diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -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) diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs --- a/Network/TLS/Record/Engage.hs +++ b/Network/TLS/Record/Engage.hs @@ -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 diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs --- a/Network/TLS/Record/Types.hs +++ b/Network/TLS/Record/Types.hs @@ -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 diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -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 diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Session.hs @@ -0,0 +1,30 @@ +-- | +-- Module : Network.TLS.Session +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE ExistentialQuantification #-} +module Network.TLS.Session + ( SessionManager(..) + , NoSessionManager(..) + ) where + +import Network.TLS.Types + +-- | A session manager +class SessionManager a where + -- | used on server side to decide whether to resume a client session + sessionResume :: a -> SessionID -> IO (Maybe SessionData) + -- | used when a session is established. + sessionEstablish :: a -> SessionID -> SessionData -> IO () + -- | used when a session is invalidated + sessionInvalidate :: a -> SessionID -> IO () + +data NoSessionManager = NoSessionManager + +instance SessionManager NoSessionManager where + sessionResume _ _ = return Nothing + sessionEstablish _ _ _ = return () + sessionInvalidate _ _ = return () diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -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 }) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -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) diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Network.TLS.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Types + ( Version(..) + , SessionID + , SessionData(..) + , CipherID + , CompressionID + ) where + +import Data.ByteString (ByteString) +import Data.Word + +-- | Versions known to TLS +-- +-- SSL2 is just defined, but this version is and will not be supported. +data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord) + +-- | A session ID +type SessionID = ByteString + +-- | Session data to resume +data SessionData = SessionData + { sessionVersion :: Version + , sessionCipher :: CipherID + , sessionSecret :: ByteString + } + +-- | Cipher identification +type CipherID = Word16 + +-- | Compression identification +type CompressionID = Word8 diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -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 diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -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 diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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 -p -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. - diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -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 diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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) + ] diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs new file mode 100644 --- /dev/null +++ b/Tests/Certificate.hs @@ -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 diff --git a/Tests/Connection.hs b/Tests/Connection.hs new file mode 100644 --- /dev/null +++ b/Tests/Connection.hs @@ -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') diff --git a/Tests/PipeChan.hs b/Tests/PipeChan.hs new file mode 100644 --- /dev/null +++ b/Tests/PipeChan.hs @@ -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) diff --git a/Tests/PubKey.hs b/Tests/PubKey.hs new file mode 100644 --- /dev/null +++ b/Tests/PubKey.hs @@ -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) diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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