diff --git a/Benchmarks/Benchmarks.hs b/Benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/Benchmarks/Benchmarks.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Connection +import Certificate +import PubKey +import Criterion.Main +import Control.Concurrent.Chan +import Network.TLS +import Data.X509 +import Data.X509.Validation +import Data.Default.Class + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l + +getParams connectVer cipher = (cParams, sParams) + where sParams = def { serverSupported = supported + , serverShared = def { + sharedCredentials = Credentials [ (CertificateChain [simpleX509 $ PubKeyRSA pubKey], PrivKeyRSA privKey) ] + } + } + cParams = (defaultParamsClient "" B.empty) + { clientSupported = supported + , clientShared = def { sharedValidationCache = ValidationCache + { cacheAdd = \_ _ _ -> return () + , cacheQuery = \_ _ _ -> return ValidationCachePass + } + } + } + supported = def { supportedCiphers = [cipher] + , supportedVersions = [connectVer] + } + (pubKey, privKey) = getGlobalRSAPair + +runTLSPipe params tlsServer tlsClient d name = bench name $ do + (startQueue, resultQueue) <- establishDataPipe params tlsServer tlsClient + writeChan startQueue d + readChan resultQueue + +bench1 params !d name = runTLSPipe params tlsServer tlsClient d name + where tlsServer ctx queue = do + handshake ctx + d <- recvDataNonNull ctx + writeChan queue d + return () + tlsClient queue ctx = do + handshake ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + bye ctx + return () + +main = defaultMain + [ bgroup "connection" + -- not sure the number actually make sense for anything. improve .. + [ bench1 (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes" + , bench1 (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes" + , bench1 (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes" + , bench1 (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes" + ] + ] diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -8,19 +8,18 @@ module Network.TLS ( -- * Context configuration - Params(..) - , RoleParams(..) - , ClientParams(..) + ClientParams(..) , ServerParams(..) - , updateClientParams - , updateServerParams + , ClientHooks(..) + , ServerHooks(..) + , Supported(..) + , Shared(..) + , Hooks(..) , Logging(..) , Measurement(..) , CertificateUsage(..) , CertificateRejectReason(..) , defaultParamsClient - , defaultParamsServer - , defaultLogging , MaxFragmentEnum(..) , HashAndSignatureAlgorithm , HashAlgorithm(..) @@ -35,8 +34,7 @@ , SessionID , SessionData(..) , SessionManager(..) - , NoSessionManager(..) - , setSessionManager + , noSessionManager -- * Backend abstraction , Backend(..) @@ -48,18 +46,22 @@ -- * Creating a context , contextNew , contextNewOnHandle + , contextNewOnSocket , contextFlush , contextClose + , contextHookSetHandshakeRecv + , contextHookSetCertificateRecv + , contextHookSetLogging + , contextModifyHooks - -- * deprecated type aliases - , TLSParams - , TLSLogging - , TLSCertificateUsage - , TLSCertificateRejectReason - , TLSCtx + -- * Information gathering + , Information(..) + , contextGetInformation - -- * deprecated values - , defaultParams + -- * Credentials + , Credentials(..) + , Credential + , credentialLoadX509 -- * Initialisation and Termination of context , bye @@ -74,7 +76,8 @@ , recvData' -- * Crypto Key - , PrivateKey(..) + , PubKey(..) + , PrivKey(..) -- * Compressions & Predefined compressions , module Network.TLS.Compression @@ -91,15 +94,34 @@ , AlertDescription(..) -- * Exceptions - , Terminated(..) - , HandshakeFailed(..) - , ConnectionNotEstablished(..) + , TLSException(..) + + -- * X509 Validation + , ValidationChecks(..) + , ValidationHooks(..) + + -- * X509 Validation Cache + , ValidationCache(..) + , ValidationCacheResult(..) + , exceptionValidationCache ) where -import Network.TLS.Struct (Version(..), TLSError(..), HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..), Header(..), ProtocolType(..), CertificateType(..), AlertDescription(..)) -import Network.TLS.Crypto (PrivateKey(..), KxError(..)) +import Network.TLS.Backend (Backend(..)) +import Network.TLS.Struct ( TLSError(..), TLSException(..) + , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..) + , Header(..), ProtocolType(..), CertificateType(..) + , AlertDescription(..)) +import Network.TLS.Crypto (KxError(..)) import Network.TLS.Cipher +import Network.TLS.Hooks +import Network.TLS.Measurement +import Network.TLS.Credentials import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) import Network.TLS.Context +import Network.TLS.Parameters import Network.TLS.Core import Network.TLS.Session +import Network.TLS.X509 +import Network.TLS.Types +import Data.X509 (PubKey(..), PrivKey(..)) +import Data.X509.Validation diff --git a/Network/TLS/Backend.hs b/Network/TLS/Backend.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Backend.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Network.TLS.Backend +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Backend represent a unified way to do IO on differents +-- types without burdening our calling API with multiples +-- way to initialize a new context. +-- +-- Typically any backend much implement: +-- * a way to read data +-- * a way to write data +-- * a way to close the stream +-- * a way to flush the stream +-- +module Network.TLS.Backend + ( HasBackend(..) + , Backend(..) + ) where + +import Control.Monad +import Network.Socket (Socket, sClose) +import qualified Network.Socket.ByteString as Socket +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) + +-- | Connection IO backend +data Backend = Backend + { backendFlush :: IO () -- ^ Flush the connection sending buffer, if any. + , backendClose :: IO () -- ^ Close the connection. + , backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection. + , backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection. + } + +class HasBackend a where + initializeBackend :: a -> IO () + getBackend :: a -> Backend + +instance HasBackend Backend where + initializeBackend _ = return () + getBackend = id + +instance HasBackend Socket where + initializeBackend _ = return () + getBackend sock = Backend (return ()) (sClose sock) (Socket.sendAll sock) recvAll + where recvAll n = B.concat `fmap` loop n + where loop 0 = return [] + loop left = do + r <- Socket.recv sock left + liftM (r:) (loop (left - B.length r)) + +instance HasBackend Handle where + initializeBackend handle = hSetBuffering handle NoBuffering + getBackend handle = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle) 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,17 +8,18 @@ -- Portability : unknown -- module Network.TLS.Cipher - ( BulkFunctions(..) - , CipherKeyExchangeType(..) - , Bulk(..) - , Hash(..) - , Cipher(..) - , CipherID - , cipherKeyBlockSize - , Key - , IV - , cipherExchangeNeedMoreData - ) where + ( BulkFunctions(..) + , CipherKeyExchangeType(..) + , Bulk(..) + , Hash(..) + , Cipher(..) + , CipherID + , Key + , IV + , cipherKeyBlockSize + , cipherAllowedForVersion + , cipherExchangeNeedMoreData + ) where import Network.TLS.Types (CipherID) import Network.TLS.Struct (Version(..)) @@ -30,58 +31,80 @@ type IV = B.ByteString data BulkFunctions = - BulkBlockF (Key -> IV -> B.ByteString -> B.ByteString) - (Key -> IV -> B.ByteString -> B.ByteString) - | BulkStreamF (Key -> IV) - (IV -> B.ByteString -> (B.ByteString, IV)) - (IV -> B.ByteString -> (B.ByteString, IV)) + 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 + } +instance Show Bulk where + show bulk = bulkName bulk +instance Eq Bulk where + b1 == b2 = and [ bulkName b1 == bulkName b2 + , bulkKeySize b1 == bulkKeySize b2 + , bulkIVSize b1 == bulkIVSize b2 + , bulkBlockSize b1 == bulkBlockSize b2 + ] + data Hash = Hash - { hashName :: String - , hashSize :: Int - , hashF :: B.ByteString -> B.ByteString - } + { hashName :: String + , hashSize :: Int + , hashF :: B.ByteString -> B.ByteString + } +instance Show Hash where + show hash = hashName hash +instance Eq Hash where + h1 == h2 = hashName h1 == hashName h2 && hashSize h1 == hashSize h2 + -- | Cipher algorithm data Cipher = Cipher - { cipherID :: CipherID - , 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 +-- | Check if a specific 'Cipher' is allowed to be used +-- with the version specified +cipherAllowedForVersion :: Version -> Cipher -> Bool +cipherAllowedForVersion ver cipher = + case cipherMinVer cipher of + Nothing -> True + Just cVer -> cVer <= ver + instance Show Cipher where - show c = cipherName c + 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,20 +8,20 @@ -- Portability : unknown -- module Network.TLS.Compression - ( CompressionC(..) - , Compression(..) - , CompressionID - , nullCompression - , 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) @@ -30,9 +30,9 @@ -- | supported compression algorithms need to be part of this class class CompressionC a where - compressionCID :: a -> CompressionID - compressionCDeflate :: a -> ByteString -> (a, ByteString) - compressionCInflate :: a -> ByteString -> (a, ByteString) + 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 @@ -52,7 +52,9 @@ compressionInflate bytes (Compression c) = first Compression $ compressionCInflate c bytes instance Show Compression where - show = show . compressionID + show = show . compressionID +instance Eq Compression where + (==) c1 c2 = compressionID c1 == compressionID c2 -- | intersect a list of ids commonly given by the other side with a list of compression -- the function keeps the list of compression in order, to be able to find quickly the prefered @@ -64,9 +66,9 @@ 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 @@ -5,388 +5,213 @@ -- Stability : experimental -- Portability : unknown -- -{-# LANGUAGE ExistentialQuantification, Rank2Types #-} --- only needed because of some GHC bug relative to insufficient polymorphic field -{-# LANGUAGE RecordWildCards #-} module Network.TLS.Context - ( - -- * Context configuration - Params(..) - , RoleParams(..) - , ClientParams(..) - , ServerParams(..) - , updateClientParams - , updateServerParams - , Logging(..) - , SessionID - , SessionData(..) - , MaxFragmentEnum(..) - , Measurement(..) - , CertificateUsage(..) - , CertificateRejectReason(..) - , defaultLogging - , defaultParamsClient - , defaultParamsServer - , withSessionManager - , setSessionManager + ( + -- * Context configuration + TLSParams - -- * Context object and accessor - , Backend(..) - , Context - , ctxParams - , ctxConnection - , ctxEOF - , ctxHasSSLv2ClientHello - , ctxDisableSSLv2ClientHello - , ctxEstablished - , ctxLogging - , setEOF - , setEstablished - , contextFlush - , contextClose - , contextSend - , contextRecv - , updateMeasure - , withMeasure + -- * Context object and accessor + , Context(..) + , Hooks(..) + , ctxEOF + , ctxHasSSLv2ClientHello + , ctxDisableSSLv2ClientHello + , ctxEstablished + , withLog + , ctxWithHooks + , contextModifyHooks + , setEOF + , setEstablished + , contextFlush + , contextClose + , contextSend + , contextRecv + , updateMeasure + , withMeasure + , withReadLock + , withWriteLock + , withStateLock + , withRWLock - -- * deprecated types - , TLSParams - , TLSLogging - , TLSCertificateUsage - , TLSCertificateRejectReason - , TLSCtx + -- * information + , Information(..) + , contextGetInformation - -- * deprecated values - , defaultParams + -- * New contexts + , contextNew + -- * Deprecated new contexts methods + , contextNewOnHandle + , contextNewOnSocket - -- * New contexts - , contextNew - , contextNewOnHandle + -- * Context hooks + , contextHookSetHandshakeRecv + , contextHookSetCertificateRecv + , contextHookSetLogging - -- * Using context states - , throwCore - , usingState - , usingState_ - , getStateRNG - ) where + -- * Using context states + , throwCore + , usingState + , usingState_ + , runTxState + , runRxState + , usingHState + , getHState + , getStateRNG + ) where -import Network.BSD (HostName) -import Network.TLS.Extension +import Network.TLS.Backend +import Network.TLS.Context.Internal import Network.TLS.Struct -import qualified Network.TLS.Struct as Struct -import Network.TLS.Session -import Network.TLS.Cipher -import Network.TLS.Compression -import Network.TLS.Crypto +import Network.TLS.Cipher (Cipher(..), CipherKeyExchangeType(..)) +import Network.TLS.Credentials import Network.TLS.State +import Network.TLS.Hooks +import Network.TLS.Record.State +import Network.TLS.Parameters import Network.TLS.Measurement -import Data.Certificate.X509 -import Data.List (intercalate) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Network.TLS.Types (Role(..)) +import Network.TLS.Handshake (handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith) +import Network.TLS.X509 +import Data.Maybe (isJust) -import Crypto.Random.API +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, hClose) -data Logging = Logging - { loggingPacketSent :: String -> IO () - , loggingPacketRecv :: String -> IO () - , loggingIOSent :: B.ByteString -> IO () - , loggingIORecv :: Header -> B.ByteString -> IO () - } - -data ClientParams = ClientParams - { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum - , clientUseServerName :: Maybe HostName - , clientWantSessionResume :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session. - - -- | This action is called when the server sends a - -- certificate request. The parameter is the information - -- from the request. The action should select a certificate - -- chain of one of the given certificate types where the - -- last certificate in the chain should be signed by one of - -- the given distinguished names. Each certificate should - -- be signed by the following one, except for the last. At - -- least the first of the certificates in the chain must - -- have a corresponding private key, because that is used - -- for signing the certificate verify message. - -- - -- Note that is is the responsibility of this action to - -- select a certificate matching one of the requested - -- certificate types. Returning a non-matching one will - -- lead to handshake failure later. - -- - -- Returning a certificate chain not matching the - -- distinguished names may lead to problems or not, - -- depending whether the server accepts it. - , onCertificateRequest :: ([CertificateType], - Maybe [HashAndSignatureAlgorithm], - [DistinguishedName]) -> IO [(X509, Maybe PrivateKey)] - } - -data ServerParams = ServerParams - { serverWantClientCert :: Bool -- ^ request a certificate from client. - - -- | This is a list of certificates from which the - -- disinguished names are sent in certificate request - -- messages. For TLS1.0, it should not be empty. - , serverCACertificates :: [X509] - - -- | This action is called when a client certificate chain - -- is received from the client. When it returns a - -- CertificateUsageReject value, the handshake is aborted. - , onClientCertificate :: [X509] -> IO CertificateUsage - - -- | This action is called when the client certificate - -- cannot be verified. A 'Nothing' argument indicates a - -- wrong signature, a 'Just e' message signals a crypto - -- error. - , onUnverifiedClientCert :: IO Bool - - , onCipherChoosing :: Version -> [Cipher] -> Cipher -- ^ callback on server to modify the cipher chosen. - } - -data RoleParams = Client ClientParams | Server ServerParams - -data Params = forall s . SessionManager s => Params - { pConnectVersion :: Version -- ^ version to use on client connection. - , pAllowedVersions :: [Version] -- ^ allowed versions that we can use. - , pCiphers :: [Cipher] -- ^ all ciphers supported ordered by priority. - , pCompressions :: [Compression] -- ^ all compression supported ordered by priority. - , pHashSignatures :: [HashAndSignatureAlgorithm] -- ^ All supported hash/signature algorithms pair for client certificate verification, ordered by decreasing priority. - , pUseSecureRenegotiation :: Bool -- ^ notify that we want to use secure renegotation - , pUseSession :: Bool -- ^ generate new session if specified - , pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any. - , pLogging :: Logging -- ^ callback for logging - , onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake - , onCertificatesRecv :: [X509] -> IO CertificateUsage -- ^ callback to verify received cert chain. - , pSessionManager :: s - , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- ^ suggested next protocols accoring to the next protocol negotiation extension. - , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) - , roleParams :: RoleParams - } - --- | Set a new session manager in a parameters structure. -setSessionManager :: SessionManager s => s -> Params -> Params -setSessionManager manager (Params {..}) = Params { pSessionManager = manager, .. } - -withSessionManager :: Params -> (forall s . SessionManager s => s -> a) -> a -withSessionManager (Params { pSessionManager = man }) f = f man - -defaultLogging :: Logging -defaultLogging = Logging - { loggingPacketSent = (\_ -> return ()) - , loggingPacketRecv = (\_ -> return ()) - , loggingIOSent = (\_ -> return ()) - , loggingIORecv = (\_ _ -> return ()) - } - -defaultParamsClient :: Params -defaultParamsClient = Params - { pConnectVersion = TLS10 - , pAllowedVersions = [TLS10,TLS11,TLS12] - , pCiphers = [] - , pCompressions = [nullCompression] - , pHashSignatures = [ (Struct.HashSHA512, SignatureRSA) - , (Struct.HashSHA384, SignatureRSA) - , (Struct.HashSHA256, SignatureRSA) - , (Struct.HashSHA224, SignatureRSA) - ] - , pUseSecureRenegotiation = True - , pUseSession = True - , pCertificates = [] - , pLogging = defaultLogging - , onHandshake = (\_ -> return True) - , onCertificatesRecv = (\_ -> return CertificateUsageAccept) - , pSessionManager = NoSessionManager - , onSuggestNextProtocols = return Nothing - , onNPNServerSuggest = Nothing - , roleParams = Client $ ClientParams - { clientWantSessionResume = Nothing - , clientUseMaxFragmentLength = Nothing - , clientUseServerName = Nothing - , onCertificateRequest = \ _ -> return [] - } - } - -defaultParamsServer :: Params -defaultParamsServer = defaultParamsClient { roleParams = Server role } - where role = ServerParams - { serverWantClientCert = False - , onCipherChoosing = \_ -> head - , serverCACertificates = [] - , onClientCertificate = \ _ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" - , onUnverifiedClientCert = return False - } - -updateRoleParams :: (ClientParams -> ClientParams) -> (ServerParams -> ServerParams) -> Params -> Params -updateRoleParams fc fs params = case roleParams params of - Client c -> params { roleParams = Client (fc c) } - Server s -> params { roleParams = Server (fs s) } - -updateClientParams :: (ClientParams -> ClientParams) -> Params -> Params -updateClientParams f = updateRoleParams f id - -updateServerParams :: (ServerParams -> ServerParams) -> Params -> Params -updateServerParams f = updateRoleParams id f - -defaultParams :: Params -defaultParams = defaultParamsClient -{-# DEPRECATED defaultParams "use defaultParamsClient" #-} - - -instance Show Params where - show p = "Params { " ++ (intercalate "," $ map (\(k,v) -> k ++ "=" ++ v) - [ ("connectVersion", show $ pConnectVersion p) - , ("allowedVersions", show $ pAllowedVersions p) - , ("ciphers", show $ pCiphers p) - , ("compressions", show $ pCompressions p) - , ("certificates", show $ length $ pCertificates p) - ]) ++ " }" - --- | Certificate and Chain rejection reason -data CertificateRejectReason = - CertificateRejectExpired - | CertificateRejectRevoked - | CertificateRejectUnknownCA - | CertificateRejectOther String - deriving (Show,Eq) - --- | Certificate Usage callback possible returns values. -data CertificateUsage = - CertificateUsageAccept -- ^ usage of certificate accepted - | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected - deriving (Show,Eq) - --- | Connection IO backend -data Backend = Backend - { backendFlush :: IO () -- ^ Flush the connection sending buffer, if any. - , backendClose :: IO () -- ^ Close the connection. - , backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection. - , backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection. - } - --- | A TLS Context keep tls specific state, parameters and backend information. -data Context = Context - { ctxConnection :: Backend -- ^ return the backend object associated with this context - , ctxParams :: Params - , ctxState :: MVar TLSState - , ctxMeasurement :: IORef Measurement - , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. - , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful. - , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. - -- the flag will be set to false regardless of its initial value - -- after the first packet received. - } - --- deprecated types, setup as aliases for compatibility. -type TLSParams = Params -type TLSCtx = Context -type TLSLogging = Logging -type TLSCertificateUsage = CertificateUsage -type TLSCertificateRejectReason = CertificateRejectReason - -updateMeasure :: MonadIO m => Context -> (Measurement -> Measurement) -> m () -updateMeasure ctx f = liftIO $ do - x <- readIORef (ctxMeasurement ctx) - writeIORef (ctxMeasurement ctx) $! f x - -withMeasure :: MonadIO m => Context -> (Measurement -> IO a) -> m a -withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f) - -contextFlush :: Context -> IO () -contextFlush = backendFlush . ctxConnection - -contextClose :: Context -> IO () -contextClose = backendClose . ctxConnection - -contextSend :: Context -> Bytes -> IO () -contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b - -contextRecv :: Context -> Int -> IO Bytes -contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz - -ctxEOF :: MonadIO m => Context -> m Bool -ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx) - -ctxHasSSLv2ClientHello :: MonadIO m => Context -> m Bool -ctxHasSSLv2ClientHello ctx = liftIO (readIORef $ ctxSSLv2ClientHello ctx) - -ctxDisableSSLv2ClientHello :: MonadIO m => Context -> m () -ctxDisableSSLv2ClientHello ctx = liftIO (writeIORef (ctxSSLv2ClientHello ctx) False) +-- deprecated imports +import Network.Socket (Socket) +import System.IO (Handle) -setEOF :: MonadIO m => Context -> m () -setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True +class TLSParams a where + getTLSCommonParams :: a -> CommonParams + getTLSRole :: a -> Role + getCiphers :: a -> [Cipher] + doHandshake :: a -> Context -> IO () + doHandshakeWith :: a -> Context -> Handshake -> IO () -ctxEstablished :: MonadIO m => Context -> m Bool -ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx +instance TLSParams ClientParams where + getTLSCommonParams cparams = ( clientSupported cparams + , clientShared cparams + ) + getTLSRole _ = ClientRole + getCiphers cparams = supportedCiphers $ clientSupported cparams + doHandshake = handshakeClient + doHandshakeWith = handshakeClientWith -setEstablished :: MonadIO m => Context -> Bool -> m () -setEstablished ctx v = liftIO $ writeIORef (ctxEstablished_ ctx) v +instance TLSParams ServerParams where + getTLSCommonParams sparams = ( serverSupported sparams + , serverShared sparams + ) + getTLSRole _ = ServerRole + -- on the server we filter our allowed ciphers here according + -- to the credentials and DHE parameters loaded + getCiphers sparams = filter authorizedCKE (supportedCiphers $ serverSupported sparams) + where authorizedCKE cipher = + case cipherKeyExchange cipher of + CipherKeyExchange_RSA -> canEncryptRSA + CipherKeyExchange_DH_Anon -> canDHE + CipherKeyExchange_DHE_RSA -> canSignRSA && canDHE + CipherKeyExchange_DHE_DSS -> canSignDSS && canDHE + -- unimplemented: non ephemeral DH + CipherKeyExchange_DH_DSS -> False + CipherKeyExchange_DH_RSA -> False + -- unimplemented: EC + CipherKeyExchange_ECDHE_RSA -> False + CipherKeyExchange_ECDH_ECDSA -> False + CipherKeyExchange_ECDH_RSA -> False + CipherKeyExchange_ECDHE_ECDSA -> False -ctxLogging :: Context -> Logging -ctxLogging = pLogging . ctxParams + canDHE = isJust $ serverDHEParams sparams + canSignDSS = SignatureDSS `elem` signingAlgs + canSignRSA = SignatureRSA `elem` signingAlgs + canEncryptRSA = isJust $ credentialsFindForDecrypting creds + signingAlgs = credentialsListSigningAlgorithms creds + creds = sharedCredentials $ serverShared sparams + doHandshake = handshakeServer + doHandshakeWith = handshakeServerWith -- | create a new context using the backend and parameters specified. -contextNew :: (MonadIO m, CPRG rng) - => Backend -- ^ Backend abstraction with specific method to interact with the connection type. - -> Params -- ^ Parameters of the context. +contextNew :: (MonadIO m, CPRG rng, HasBackend backend, TLSParams params) + => backend -- ^ Backend abstraction with specific method to interact with the connection type. + -> params -- ^ Parameters of the context. -> rng -- ^ Random number generator associated with this context. -> m Context contextNew backend params rng = liftIO $ do - let clientContext = case roleParams params of - Client {} -> True - Server {} -> False - let st = (newTLSState rng) { stClientContext = clientContext } + initializeBackend backend - stvar <- newMVar st - eof <- newIORef False - established <- newIORef False - stats <- newIORef newMeasurement - -- we enable the reception of SSLv2 ClientHello message only in the - -- server context, where we might be dealing with an old/compat client. - sslv2Compat <- newIORef (not clientContext) - return $ Context - { ctxConnection = backend - , ctxParams = params - , ctxState = stvar - , ctxMeasurement = stats - , ctxEOF_ = eof - , ctxEstablished_ = established - , ctxSSLv2ClientHello = sslv2Compat - } + let role = getTLSRole params + st = newTLSState rng role + (supported, shared) = getTLSCommonParams params + ciphers = getCiphers params + when (null ciphers) $ error "no ciphers available with those parameters" + + stvar <- newMVar st + eof <- newIORef False + established <- newIORef False + stats <- newIORef newMeasurement + -- we enable the reception of SSLv2 ClientHello message only in the + -- server context, where we might be dealing with an old/compat client. + sslv2Compat <- newIORef (role == ServerRole) + needEmptyPacket <- newIORef False + hooks <- newIORef defaultHooks + tx <- newMVar newRecordState + rx <- newMVar newRecordState + hs <- newMVar Nothing + lockWrite <- newMVar () + lockRead <- newMVar () + lockState <- newMVar () + + return $ Context + { ctxConnection = getBackend backend + , ctxShared = shared + , ctxSupported = supported + , ctxCiphers = ciphers + , ctxState = stvar + , ctxTxState = tx + , ctxRxState = rx + , ctxHandshake = hs + , ctxDoHandshake = doHandshake params + , ctxDoHandshakeWith = doHandshakeWith params + , ctxMeasurement = stats + , ctxEOF_ = eof + , ctxEstablished_ = established + , ctxSSLv2ClientHello = sslv2Compat + , ctxNeedEmptyPacket = needEmptyPacket + , ctxHooks = hooks + , ctxLockWrite = lockWrite + , ctxLockRead = lockRead + , ctxLockState = lockState + } + -- | create a new context on an handle. -contextNewOnHandle :: (MonadIO m, CPRG rng) +contextNewOnHandle :: (MonadIO m, CPRG rng, TLSParams params) => Handle -- ^ Handle of the connection. - -> Params -- ^ Parameters of the context. + -> 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 +contextNewOnHandle handle params st = contextNew handle params st +{-# DEPRECATED contextNewOnHandle "use contextNew" #-} +-- | create a new context on a socket. +contextNewOnSocket :: (MonadIO m, CPRG rng, TLSParams params) + => Socket -- ^ Socket of the connection. + -> params -- ^ Parameters of the context. + -> rng -- ^ Random number generator associated with this context. + -> m Context +contextNewOnSocket sock params st = contextNew sock params st +{-# DEPRECATED contextNewOnSocket "use contextNew" #-} -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) +contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () +contextHookSetHandshakeRecv context f = + contextModifyHooks context (\hooks -> hooks { hookRecvHandshake = f }) -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 +contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO () +contextHookSetCertificateRecv context f = + contextModifyHooks context (\hooks -> hooks { hookRecvCertificates = f }) -getStateRNG :: MonadIO m => Context -> Int -> m Bytes -getStateRNG ctx n = usingState_ ctx (genTLSRandom n) +contextHookSetLogging :: Context -> Logging -> IO () +contextHookSetLogging context loggingCallbacks = + contextModifyHooks context (\hooks -> hooks { hookLogging = loggingCallbacks }) diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Context/Internal.hs @@ -0,0 +1,223 @@ +-- | +-- Module : Network.TLS.Context.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Context.Internal + ( + -- * Context configuration + ClientParams(..) + , ServerParams(..) + , defaultParamsClient + , SessionID + , SessionData(..) + , MaxFragmentEnum(..) + , Measurement(..) + + -- * Context object and accessor + , Context(..) + , Hooks(..) + , ctxEOF + , ctxHasSSLv2ClientHello + , ctxDisableSSLv2ClientHello + , ctxEstablished + , withLog + , ctxWithHooks + , contextModifyHooks + , setEOF + , setEstablished + , contextFlush + , contextClose + , contextSend + , contextRecv + , updateMeasure + , withMeasure + , withReadLock + , withWriteLock + , withStateLock + , withRWLock + + -- * information + , Information(..) + , contextGetInformation + + -- * Using context states + , throwCore + , usingState + , usingState_ + , runTxState + , runRxState + , usingHState + , getHState + , getStateRNG + ) where + +import Network.TLS.Backend +import Network.TLS.Extension +import Network.TLS.Cipher +import Network.TLS.Struct +import Network.TLS.Compression (Compression) +import Network.TLS.State +import Network.TLS.Handshake.State +import Network.TLS.Hooks +import Network.TLS.Record.State +import Network.TLS.Parameters +import Network.TLS.Measurement +import qualified Data.ByteString as B + +import Control.Concurrent.MVar +import Control.Monad.State +import Control.Exception (throwIO, Exception()) +import Data.IORef +import Data.Tuple + + +-- | Information related to a running context, e.g. current cipher +data Information = Information + { infoVersion :: Version + , infoCipher :: Cipher + , infoCompression :: Compression + } deriving (Show,Eq) + +-- | A TLS Context keep tls specific state, parameters and backend information. +data Context = Context + { ctxConnection :: Backend -- ^ return the backend object associated with this context + , ctxSupported :: Supported + , ctxShared :: Shared + , ctxCiphers :: [Cipher] -- ^ prepared list of allowed ciphers according to parameters + , ctxState :: MVar TLSState + , ctxMeasurement :: IORef Measurement + , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. + , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful. + , ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability. + , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. + -- the flag will be set to false regardless of its initial value + -- after the first packet received. + , ctxTxState :: MVar RecordState -- ^ current tx state + , ctxRxState :: MVar RecordState -- ^ current rx state + , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state + , ctxDoHandshake :: Context -> IO () + , ctxDoHandshakeWith :: Context -> Handshake -> IO () + , ctxHooks :: IORef Hooks -- ^ hooks for this context + , ctxLockWrite :: MVar () -- ^ lock to use for writing data (including updating the state) + , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) + , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. + -- it is usually nested in a write or read lock. + } + +updateMeasure :: Context -> (Measurement -> Measurement) -> IO () +updateMeasure ctx f = do + x <- readIORef (ctxMeasurement ctx) + writeIORef (ctxMeasurement ctx) $! f x + +withMeasure :: Context -> (Measurement -> IO a) -> IO a +withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f + +contextFlush :: Context -> IO () +contextFlush = backendFlush . ctxConnection + +contextClose :: Context -> IO () +contextClose = backendClose . ctxConnection + +-- | Information about the current context +contextGetInformation :: Context -> IO (Maybe Information) +contextGetInformation ctx = do + ver <- usingState_ ctx $ gets stVersion + (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st) + case (ver, cipher) of + (Just v, Just c) -> return $ Just $ Information v c comp + _ -> return Nothing + +contextSend :: Context -> Bytes -> IO () +contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b + +contextRecv :: Context -> Int -> IO Bytes +contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz + +ctxEOF :: Context -> IO Bool +ctxEOF ctx = readIORef $ ctxEOF_ ctx + +ctxHasSSLv2ClientHello :: Context -> IO Bool +ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx + +ctxDisableSSLv2ClientHello :: Context -> IO () +ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False + +setEOF :: Context -> IO () +setEOF ctx = writeIORef (ctxEOF_ ctx) True + +ctxEstablished :: Context -> IO Bool +ctxEstablished ctx = readIORef $ ctxEstablished_ ctx + +ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a +ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f + +contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO () +contextModifyHooks ctx f = modifyIORef (ctxHooks ctx) f + +setEstablished :: Context -> Bool -> IO () +setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v + +withLog :: Context -> (Logging -> IO ()) -> IO () +withLog ctx f = ctxWithHooks ctx (f . hookLogging) + +throwCore :: (MonadIO m, Exception e) => e -> m a +throwCore = liftIO . throwIO + +failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a +failOnEitherError f = do + ret <- f + case ret of + Left err -> throwCore err + Right r -> return r + +usingState :: Context -> TLSSt a -> IO (Either TLSError a) +usingState ctx f = + modifyMVar (ctxState ctx) $ \st -> + let (a, newst) = runTLSState f st + in newst `seq` return (newst, a) + +usingState_ :: Context -> TLSSt a -> IO a +usingState_ ctx f = failOnEitherError $ usingState ctx f + +usingHState :: Context -> HandshakeM a -> IO a +usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> + case mst of + Nothing -> throwCore $ Error_Misc "missing handshake" + Just st -> return $ swap (Just `fmap` runHandshake st f) + +getHState :: Context -> IO (Maybe HandshakeState) +getHState ctx = liftIO $ readMVar (ctxHandshake ctx) + +runTxState :: Context -> RecordM a -> IO (Either TLSError a) +runTxState ctx f = do + ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) + modifyMVar (ctxTxState ctx) $ \st -> + case runRecordM f ver st of + Left err -> return (st, Left err) + Right (a, newSt) -> return (newSt, Right a) + +runRxState :: Context -> RecordM a -> IO (Either TLSError a) +runRxState ctx f = do + ver <- usingState_ ctx getVersion + modifyMVar (ctxRxState ctx) $ \st -> + case runRecordM f ver st of + Left err -> return (st, Left err) + Right (a, newSt) -> return (newSt, Right a) + +getStateRNG :: Context -> Int -> IO Bytes +getStateRNG ctx n = usingState_ ctx $ genRandom n + +withReadLock :: Context -> IO a -> IO a +withReadLock ctx f = withMVar (ctxLockRead ctx) (const f) + +withWriteLock :: Context -> IO a -> IO a +withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f) + +withRWLock :: Context -> IO a -> IO a +withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f + +withStateLock :: Context -> IO a -> IO a +withStateLock ctx f = withMVar (ctxLockState ctx) (const f) diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -- | -- Module : Network.TLS.Core -- License : BSD-style @@ -8,34 +8,32 @@ -- Portability : unknown -- module Network.TLS.Core - ( - -- * Internal packet sending and receiving - sendPacket - , recvPacket + ( + -- * Internal packet sending and receiving + sendPacket + , recvPacket - -- * Initialisation and Termination of context - , bye - , handshake - , HandshakeFailed(..) - , ConnectionNotEstablished(..) + -- * Initialisation and Termination of context + , bye + , handshake - -- * Next Protocol Negotiation - , getNegotiatedProtocol + -- * Next Protocol Negotiation + , getNegotiatedProtocol - -- * High level API - , Terminated(..) - , sendData - , recvData - , recvData' - ) where + -- * High level API + , sendData + , recvData + , recvData' + ) where import Network.TLS.Context import Network.TLS.Struct import Network.TLS.State (getSession) +import Network.TLS.Parameters import Network.TLS.IO import Network.TLS.Session import Network.TLS.Handshake -import Data.Typeable +import Network.TLS.Util (catchException) import qualified Network.TLS.State as S import qualified Data.ByteString as B import Data.ByteString.Char8 () @@ -44,12 +42,7 @@ import Control.Monad.State --- | Early termination exception with the reason and the TLS error associated -data Terminated = Terminated Bool String TLSError - deriving (Eq,Show,Typeable) -instance E.Exception Terminated - -- | notify the context that this side wants to close connection. -- this is important that it is called before closing the handle, otherwise -- the session might not be resumable (for version < TLS1.2). @@ -61,65 +54,73 @@ -- | 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 +getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => Context -> L.ByteString -> m () -sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks dataToSend) - where sendDataChunk d - | B.length d > 16384 = do - let (sending, remain) = B.splitAt 16384 d - sendPacket ctx $ AppData sending - sendDataChunk remain - | otherwise = sendPacket ctx $ AppData d +sendData ctx dataToSend = liftIO (checkValid ctx) >> mapM_ sendDataChunk (L.toChunks dataToSend) + where sendDataChunk d + | B.length d > 16384 = do + let (sending, remain) = B.splitAt 16384 d + sendPacket ctx $ AppData sending + sendDataChunk remain + | otherwise = sendPacket ctx $ AppData d -- | recvData get data out of Data packet, and automatically renegotiate if -- a Handshake ClientHello is received recvData :: MonadIO m => Context -> m B.ByteString -recvData ctx = checkValid ctx >> recvPacket ctx >>= either onError process - where onError err@(Error_Protocol (reason,fatal,desc)) = +recvData ctx = liftIO $ do + checkValid ctx + pkt <- withReadLock ctx $ recvPacket ctx + either onError process pkt + where onError err@(Error_Protocol (reason,fatal,desc)) = terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason - onError err = + onError err = terminate err AlertLevel_Fatal InternalError (show err) - process (Handshake [ch@(ClientHello {})]) = - -- on server context receiving a client hello == renegotiation + process (Handshake [ch@(ClientHello {})]) = + withRWLock ctx ((ctxDoHandshakeWith ctx) ctx ch) >> recvData ctx + {- case roleParams $ ctxParams ctx of - Server sparams -> handshakeServerWith sparams ctx ch >> recvData ctx + Server sparams -> withRWLock ctx (handshakeServerWith sparams ctx ch) >> recvData ctx Client {} -> let reason = "unexpected client hello in client context" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - process (Handshake [HelloRequest]) = + -} + process (Handshake [hr@HelloRequest]) = + withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hr) >> recvData ctx + {- -- on client context, receiving a hello request == renegotiation case roleParams $ ctxParams ctx of Server {} -> let reason = "unexpected hello request in server context" in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - Client cparams -> handshakeClient cparams ctx >> recvData ctx + Client cparams -> withRWLock ctx (handshakeClient cparams ctx) >> recvData ctx + -} - process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty - process (Alert [(AlertLevel_Fatal, desc)]) = do + process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty + process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx - liftIO $ E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) + E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) - -- when receiving empty appdata, we just retry to get some data. - process (AppData "") = recvData ctx - process (AppData x) = return x - process p = let reason = "unexpected message " ++ show p in - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + -- when receiving empty appdata, we just retry to get some data. + process (AppData "") = recvData ctx + process (AppData x) = return x + process p = let reason = "unexpected message " ++ show p in + terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - terminate :: MonadIO m => TLSError -> AlertLevel -> AlertDescription -> String -> m a - terminate err level desc reason = do + terminate :: TLSError -> AlertLevel -> AlertDescription -> String -> IO a + terminate err level desc reason = do session <- usingState_ ctx getSession case session of Session Nothing -> return () - Session (Just sid) -> withSessionManager (ctxParams ctx) (\s -> liftIO $ sessionInvalidate s sid) - liftIO $ E.catch (sendPacket ctx $ Alert [(level, desc)]) (\(_ :: E.SomeException) -> return ()) + Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid + catchException (sendPacket ctx $ Alert [(level, desc)]) (\_ -> return ()) setEOF ctx - liftIO $ E.throwIO (Terminated False reason err) + E.throwIO (Terminated False reason err) - -- the other side could have close the connection already, so wrap - -- this in a try and ignore all exceptions - tryBye = liftIO $ E.catch (bye ctx) (\(_ :: E.SomeException) -> return ()) + -- the other side could have close the connection already, so wrap + -- this in a try and ignore all exceptions + tryBye = catchException (bye ctx) (\_ -> return ()) {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} -- | same as recvData but returns a lazy bytestring. diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Credentials.hs @@ -0,0 +1,90 @@ +-- | +-- Module : Network.TLS.Credentials +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Credentials + ( Credential + , Credentials(..) + , credentialLoadX509 + , credentialsFindForSigning + , credentialsFindForDecrypting + , credentialsListSigningAlgorithms + ) where + +import Data.Monoid +import Data.Maybe (catMaybes) +import Data.List (find) +import Network.TLS.Struct +import Network.TLS.X509 +import Data.X509.File +import Data.X509 + +type Credential = (CertificateChain, PrivKey) + +newtype Credentials = Credentials [Credential] + +instance Monoid Credentials where + mempty = Credentials [] + mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2) + +-- | try to create a new credential object from a public certificate +-- and the associated private key. +credentialLoadX509 :: FilePath -- ^ public certificate (X.509 format) + -> FilePath -- ^ private key associated + -> IO (Either String Credential) +credentialLoadX509 certFile privateFile = do + x509 <- readSignedObject certFile + keys <- readKeyFile privateFile + case keys of + [] -> return $ Left "no keys found" + (k:_) -> return $ Right (CertificateChain x509, k) + +credentialsListSigningAlgorithms :: Credentials -> [SignatureAlgorithm] +credentialsListSigningAlgorithms (Credentials l) = catMaybes $ map credentialCanSign l + +credentialsFindForSigning :: SignatureAlgorithm -> Credentials -> Maybe (CertificateChain, PrivKey) +credentialsFindForSigning sigAlg (Credentials l) = find forSigning l + where forSigning cred = Just sigAlg == credentialCanSign cred + +credentialsFindForDecrypting :: Credentials -> Maybe (CertificateChain, PrivKey) +credentialsFindForDecrypting (Credentials l) = find forEncrypting l + where forEncrypting cred = Just () == credentialCanDecrypt cred + +-- here we assume that only RSA is supported for key encipherment (encryption/decryption) +-- we keep the same construction as 'credentialCanSign', returning a Maybe of () in case +-- this change in future. +credentialCanDecrypt :: Credential -> Maybe () +credentialCanDecrypt (chain, priv) = + case extensionGet (certExtensions cert) of + Nothing -> Nothing + Just (ExtKeyUsage flags) + | KeyUsage_keyEncipherment `elem` flags -> + case (pub, priv) of + (PubKeyRSA _, PrivKeyRSA _) -> Just () + _ -> Nothing + | otherwise -> Nothing + where cert = signedObject $ getSigned signed + pub = certPubKey cert + signed = getCertificateChainLeaf chain + +credentialCanSign :: Credential -> Maybe SignatureAlgorithm +credentialCanSign (chain, priv) = + case extensionGet (certExtensions cert) of + Nothing -> Nothing + Just (ExtKeyUsage flags) + | KeyUsage_digitalSignature `elem` flags -> getSignatureAlg pub priv + | otherwise -> Nothing + where cert = signedObject $ getSigned signed + pub = certPubKey cert + signed = getCertificateChainLeaf chain + +getSignatureAlg :: PubKey -> PrivKey -> Maybe SignatureAlgorithm +getSignatureAlg pub priv = + case (pub, priv) of + (PubKeyRSA _, PrivKeyRSA _) -> Just SignatureRSA + (PubKeyDSA _, PrivKeyDSA _) -> Just SignatureDSS + --(PubKeyECDSA _, PrivKeyECDSA _) -> Just SignatureECDSA + _ -> Nothing diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -1,81 +1,110 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Crypto - ( HashCtx(..) - , hashInit - , hashUpdate - , hashUpdateSSL - , hashFinal + ( HashCtx(..) + , hashInit + , hashUpdate + , hashUpdateSSL + , hashFinal - -- * constructor - , hashMD5SHA1 - , hashSHA256 + , module Network.TLS.Crypto.DH - -- * key exchange generic interface - , PublicKey(..) - , PrivateKey(..) - , HashDescr(..) - , kxEncrypt - , kxDecrypt - , kxSign - , kxVerify - , KxError(..) - ) where + -- * constructor + , hashMD5SHA1 + , hashSHA1 + , hashSHA256 + , hashSHA512 + -- * key exchange generic interface + , PubKey(..) + , PrivKey(..) + , PublicKey + , PrivateKey + , HashDescr(..) + , kxEncrypt + , kxDecrypt + , kxSign + , kxVerify + , KxError(..) + ) where + +import qualified Crypto.Hash.SHA512 as SHA512 import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as B import Data.ByteString (ByteString) import Crypto.PubKey.HashDescr +import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import Crypto.Random.API - -data PublicKey = PubRSA RSA.PublicKey - -data PrivateKey = PrivRSA RSA.PrivateKey +import Crypto.Random +import Data.X509 (PrivKey(..), PubKey(..)) +import Network.TLS.Crypto.DH -instance Show PublicKey where - show (_) = "PublicKey(..)" +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding (DER(..), BER(..)) -instance Show PrivateKey where - show (_) = "privateKey(..)" +{-# DEPRECATED PublicKey "use PubKey" #-} +type PublicKey = PubKey +{-# DEPRECATED PrivateKey "use PrivKey" #-} +type PrivateKey = PrivKey -data KxError = RSAError RSA.Error - deriving (Show) +data KxError = + RSAError RSA.Error + | KxUnsupported + 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 +newtype HashSHA1 = HashSHA1 SHA1.Ctx +instance HashCtxC HashSHA1 where + hashCName _ = "SHA1" + hashCInit _ = HashSHA1 SHA1.init + hashCUpdate (HashSHA1 ctx) b = HashSHA1 (SHA1.update ctx b) + hashCUpdateSSL (HashSHA1 ctx) (_,b2) = HashSHA1 (SHA1.update ctx b2) + hashCFinal (HashSHA1 ctx) = SHA1.finalize ctx + +newtype 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 _ _ = error "CUpdateSSL with HashSHA256" + hashCFinal (HashSHA256 ctx) = SHA256.finalize ctx +newtype HashSHA512 = HashSHA512 SHA512.Ctx + +instance HashCtxC HashSHA512 where + hashCName _ = "SHA512" + hashCInit _ = HashSHA512 SHA512.init + hashCUpdate (HashSHA512 ctx) b = HashSHA512 (SHA512.update ctx b) + hashCUpdateSSL _ _ = error "CUpdateSSL with HashSHA512" + hashCFinal (HashSHA512 ctx) = SHA512.finalize ctx + -- functions to use the hidden class. hashInit :: HashCtx -> HashCtx hashInit (HashCtx h) = HashCtx $ hashCInit h @@ -83,16 +112,20 @@ hashUpdate :: HashCtx -> B.ByteString -> HashCtx hashUpdate (HashCtx h) b = HashCtx $ hashCUpdate h b -hashUpdateSSL :: HashCtx -> (B.ByteString,B.ByteString) -> HashCtx +hashUpdateSSL :: HashCtx + -> (B.ByteString,B.ByteString) -- ^ (for the md5 context, for the sha1 context) + -> HashCtx hashUpdateSSL (HashCtx h) bs = HashCtx $ hashCUpdateSSL h bs hashFinal :: HashCtx -> B.ByteString hashFinal (HashCtx h) = hashCFinal h -- real hash constructors -hashMD5SHA1, hashSHA256 :: HashCtx +hashMD5SHA1, hashSHA1, hashSHA256, hashSHA512 :: HashCtx hashMD5SHA1 = HashCtx (HashMD5SHA1 SHA1.init MD5.init) +hashSHA1 = HashCtx (HashSHA1 SHA1.init) hashSHA256 = HashCtx (HashSHA256 SHA256.init) +hashSHA512 = HashCtx (HashSHA512 SHA512.init) {- key exchange methods encrypt and decrypt for each supported algorithm -} @@ -101,20 +134,34 @@ generalizeRSAWithRNG (Right x, g) = (Right x, g) kxEncrypt :: CPRG g => g -> PublicKey -> ByteString -> (Either KxError ByteString, g) -kxEncrypt g (PubRSA pk) b = generalizeRSAWithRNG $ RSA.encrypt g pk b +kxEncrypt g (PubKeyRSA pk) b = generalizeRSAWithRNG $ RSA.encrypt g pk b +kxEncrypt g _ _ = (Left KxUnsupported, g) kxDecrypt :: CPRG g => g -> PrivateKey -> ByteString -> (Either KxError ByteString, g) -kxDecrypt g (PrivRSA pk) b = generalizeRSAWithRNG $ RSA.decryptSafer g pk b +kxDecrypt g (PrivKeyRSA pk) b = generalizeRSAWithRNG $ RSA.decryptSafer g pk b +kxDecrypt g _ _ = (Left KxUnsupported, g) -- Verify that the signature matches the given message, using the -- public key. -- kxVerify :: PublicKey -> HashDescr -> ByteString -> ByteString -> Bool -kxVerify (PubRSA pk) hashDescr msg sign = - RSA.verify hashDescr pk msg sign +kxVerify (PubKeyRSA pk) hashDescr msg sign = RSA.verify hashDescr pk msg sign +kxVerify (PubKeyDSA pk) hashDescr msg signBS = + case signature of + Right (sig, []) -> DSA.verify (hashFunction hashDescr) pk sig msg + _ -> False + where signature = case decodeASN1' BER signBS of + Left err -> Left (show err) + Right asn1s -> fromASN1 asn1s +kxVerify _ _ _ _ = False -- Sign the given message using the private key. -- kxSign :: CPRG g => g -> PrivateKey -> HashDescr -> ByteString -> (Either KxError ByteString, g) -kxSign g (PrivRSA pk) hashDescr msg = +kxSign g (PrivKeyRSA pk) hashDescr msg = generalizeRSAWithRNG $ RSA.signSafer g hashDescr pk msg +kxSign g (PrivKeyDSA pk) hashDescr msg = + let (sign, g') = DSA.sign g pk (hashFunction hashDescr) msg + in (Right $ encodeASN1' DER $ toASN1 sign [], g') +--kxSign g _ _ _ = +-- (Left KxUnsupported, g) diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Crypto/DH.hs @@ -0,0 +1,53 @@ +module Network.TLS.Crypto.DH + ( + -- * DH types + DHParams + , DHPublic + , DHPrivate + + -- * DH methods + , dhPublic + , dhPrivate + , dhParams + , dhGenerateKeyPair + , dhGetShared + , dhUnwrap + , dhUnwrapPublic + ) where + +import Network.TLS.Util.Serialization (i2osp) +import qualified Crypto.PubKey.DH as DH +import qualified Crypto.Types.PubKey.DH as DH +import Crypto.Random (CPRG) +import Data.ByteString (ByteString) + +type DHPublic = DH.PublicNumber +type DHPrivate = DH.PrivateNumber +type DHParams = DH.Params +type DHKey = ByteString + +dhPublic :: Integer -> DHPublic +dhPublic = DH.PublicNumber + +dhPrivate :: Integer -> DHPrivate +dhPrivate = DH.PrivateNumber + +dhParams :: Integer -> Integer -> DHParams +dhParams = DH.Params + +dhGenerateKeyPair :: CPRG g => g -> DHParams -> ((DHPrivate, DHPublic), g) +dhGenerateKeyPair rng params = + let (priv, g') = DH.generatePrivate rng params + pub = DH.generatePublic params priv + in ((priv, pub), g') + +dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey +dhGetShared params priv pub = + let (DH.SharedKey sk) = DH.getShared params priv pub + in i2osp sk + +dhUnwrap :: DHParams -> DHPublic -> [Integer] +dhUnwrap (DH.Params p g) (DH.PublicNumber y) = [p,g,y] + +dhUnwrapPublic :: DHPublic -> Integer +dhUnwrapPublic (DH.PublicNumber y) = y diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -110,13 +110,12 @@ 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 + extensionDecode isServerHello = runGetMaybe $ do + opaque <- getOpaque8 + if isServerHello + then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque + in return $ SecureRenegotiation cvd (Just svd) + else return $ SecureRenegotiation opaque Nothing -- | Next Protocol Negotiation data NextProtocolNegotiation = NextProtocolNegotiation [ByteString] diff --git a/Network/TLS/Extra.hs b/Network/TLS/Extra.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extra.hs @@ -0,0 +1,13 @@ +-- | +-- Module : Network.TLS.Extra +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- default values and ciphers +module Network.TLS.Extra + ( module Network.TLS.Extra.Cipher + ) where + +import Network.TLS.Extra.Cipher diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extra/Cipher.hs @@ -0,0 +1,394 @@ +-- | +-- Module : Network.TLS.Extra.Cipher +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +module Network.TLS.Extra.Cipher + ( + -- * cipher suite + ciphersuite_all + , ciphersuite_medium + , ciphersuite_strong + , ciphersuite_unencrypted + , ciphersuite_dhe_rsa + , ciphersuite_dhe_dss + -- * individual ciphers + , cipher_null_SHA1 + , cipher_null_MD5 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + , cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_AES128_SHA256 + , cipher_AES256_SHA256 + , cipher_DHE_RSA_AES128_SHA1 + , cipher_DHE_RSA_AES256_SHA1 + , cipher_DHE_RSA_AES128_SHA256 + , cipher_DHE_RSA_AES256_SHA256 + , cipher_DHE_DSS_AES128_SHA1 + , cipher_DHE_DSS_AES256_SHA1 + , cipher_DHE_DSS_RC4_SHA1 + ) where + +import qualified Data.ByteString as B + +import Network.TLS (Version(..)) +import Network.TLS.Cipher +import qualified "cipher-rc4" Crypto.Cipher.RC4 as RC4 + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.MD5 as MD5 + +import qualified "cipher-aes" Crypto.Cipher.AES as AES + +aes_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes_cbc_encrypt key iv d = AES.encryptCBC (AES.initAES key) iv d + +aes_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes_cbc_decrypt key iv d = AES.decryptCBC (AES.initAES key) iv d + +aes128_cbc_encrypt + , aes128_cbc_decrypt + , aes256_cbc_encrypt + , aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString +aes128_cbc_encrypt = aes_cbc_encrypt +aes128_cbc_decrypt = aes_cbc_decrypt +aes256_cbc_encrypt = aes_cbc_encrypt +aes256_cbc_decrypt = aes_cbc_decrypt + +toIV :: RC4.Ctx -> IV +toIV (RC4.Ctx ctx) = ctx + +toCtx :: IV -> RC4.Ctx +toCtx iv = RC4.Ctx iv + +initF_rc4 :: Key -> IV +initF_rc4 key = toIV $ RC4.initCtx key + +encryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV) +encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.combine (toCtx iv) d + +decryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV) +decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.combine (toCtx iv) e + + +-- | all encrypted ciphers supported ordered from strong to weak. +-- this choice of ciphersuite should satisfy most normal need +ciphersuite_all :: [Cipher] +ciphersuite_all = + [ cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 + , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1 + , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 + , cipher_AES128_SHA256, cipher_AES256_SHA256 + , cipher_AES128_SHA1, cipher_AES256_SHA1 + , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 + ] + +-- | list of medium ciphers. +ciphersuite_medium :: [Cipher] +ciphersuite_medium = [cipher_RC4_128_MD5, cipher_RC4_128_SHA1, cipher_AES128_SHA1, cipher_AES256_SHA1] + +-- | the strongest ciphers supported. +ciphersuite_strong :: [Cipher] +ciphersuite_strong = [cipher_DHE_RSA_AES256_SHA256, cipher_AES256_SHA256, cipher_AES256_SHA1] + +-- | DHE-RSA cipher suite +ciphersuite_dhe_rsa :: [Cipher] +ciphersuite_dhe_rsa = [cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 + , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1] + +ciphersuite_dhe_dss :: [Cipher] +ciphersuite_dhe_dss = [cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1, cipher_DHE_DSS_RC4_SHA1] + +-- | all unencrypted ciphers, do not use on insecure network. +ciphersuite_unencrypted :: [Cipher] +ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] + +bulk_null, bulk_rc4, bulk_aes128, bulk_aes256 :: Bulk +bulk_null = Bulk + { bulkName = "null" + , bulkKeySize = 0 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF (const B.empty) streamId streamId + } + where streamId = \iv b -> (b,iv) + +bulk_rc4 = Bulk + { bulkName = "RC4-128" + , bulkKeySize = 16 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF initF_rc4 encryptF_rc4 decryptF_rc4 + } + +bulk_aes128 = Bulk + { bulkName = "AES128" + , bulkKeySize = 16 + , bulkIVSize = 16 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes128_cbc_encrypt aes128_cbc_decrypt + } + +bulk_aes256 = Bulk + { bulkName = "AES256" + , bulkKeySize = 32 + , bulkIVSize = 16 + , bulkBlockSize = 16 + , bulkF = BulkBlockF aes256_cbc_encrypt aes256_cbc_decrypt + } + +hash_md5, hash_sha1, hash_sha256 :: Hash +hash_md5 = Hash + { hashName = "MD5" + , hashSize = 16 + , hashF = MD5.hash + } + +hash_sha1 = Hash + { hashName = "SHA1" + , hashSize = 20 + , hashF = SHA1.hash + } + +hash_sha256 = Hash + { hashName = "SHA256" + , hashSize = 32 + , hashF = SHA256.hash + } + +-- | unencrypted cipher using RSA for key exchange and MD5 for digest +cipher_null_MD5 :: Cipher +cipher_null_MD5 = Cipher + { cipherID = 0x1 + , cipherName = "RSA-null-MD5" + , cipherBulk = bulk_null + , cipherHash = hash_md5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + +-- | unencrypted cipher using RSA for key exchange and SHA1 for digest +cipher_null_SHA1 :: Cipher +cipher_null_SHA1 = Cipher + { cipherID = 0x2 + , cipherName = "RSA-null-SHA1" + , cipherBulk = bulk_null + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + +-- | RC4 cipher, RSA key exchange and MD5 for digest +cipher_RC4_128_MD5 :: Cipher +cipher_RC4_128_MD5 = Cipher + { cipherID = 0x04 + , cipherName = "RSA-rc4-128-md5" + , cipherBulk = bulk_rc4 + , cipherHash = hash_md5 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + +-- | RC4 cipher, RSA key exchange and SHA1 for digest +cipher_RC4_128_SHA1 :: Cipher +cipher_RC4_128_SHA1 = Cipher + { cipherID = 0x05 + , cipherName = "RSA-rc4-128-sha1" + , cipherBulk = bulk_rc4 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Nothing + } + +-- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest +cipher_AES128_SHA1 :: Cipher +cipher_AES128_SHA1 = Cipher + { cipherID = 0x2f + , cipherName = "RSA-aes128-sha1" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } + +-- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest +cipher_AES256_SHA1 :: Cipher +cipher_AES256_SHA1 = Cipher + { cipherID = 0x35 + , cipherName = "RSA-aes256-sha1" + , cipherBulk = bulk_aes256 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just SSL3 + } + +-- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest +cipher_AES128_SHA256 :: Cipher +cipher_AES128_SHA256 = Cipher + { cipherID = 0x3c + , cipherName = "RSA-aes128-sha256" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha256 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +-- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest +cipher_AES256_SHA256 :: Cipher +cipher_AES256_SHA256 = Cipher + { cipherID = 0x3d + , cipherName = "RSA-aes256-sha256" + , cipherBulk = bulk_aes256 + , cipherHash = hash_sha256 + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherMinVer = Just TLS12 + } + +-- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest +cipher_DHE_RSA_AES128_SHA1 :: Cipher +cipher_DHE_RSA_AES128_SHA1 = Cipher + { cipherID = 0x33 + , cipherName = "DHE-RSA-AES128-SHA1" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + , cipherMinVer = Nothing + } + +-- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest +cipher_DHE_RSA_AES256_SHA1 :: Cipher +cipher_DHE_RSA_AES256_SHA1 = cipher_DHE_RSA_AES128_SHA1 + { cipherID = 0x39 + , cipherName = "DHE-RSA-AES256-SHA1" + , cipherBulk = bulk_aes256 + } + +-- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest +cipher_DHE_DSS_AES128_SHA1 :: Cipher +cipher_DHE_DSS_AES128_SHA1 = Cipher + { cipherID = 0x32 + , cipherName = "DHE-DSA-AES128-SHA1" + , cipherBulk = bulk_aes128 + , cipherHash = hash_sha1 + , cipherKeyExchange = CipherKeyExchange_DHE_DSS + , cipherMinVer = Nothing + } + +-- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest +cipher_DHE_DSS_AES256_SHA1 :: Cipher +cipher_DHE_DSS_AES256_SHA1 = cipher_DHE_DSS_AES128_SHA1 + { cipherID = 0x38 + , cipherName = "DHE-DSA-AES256-SHA1" + , cipherBulk = bulk_aes256 + } + +cipher_DHE_DSS_RC4_SHA1 :: Cipher +cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 + { cipherID = 0x66 + , cipherName = "DHE-DSA-RC4-SHA1" + , cipherBulk = bulk_rc4 + } + +cipher_DHE_RSA_AES128_SHA256 :: Cipher +cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1 + { cipherID = 0x67 + , cipherName = "DHE-RSA-AES128-SHA256" + , cipherHash = hash_sha256 + , cipherMinVer = Just TLS12 + } + +cipher_DHE_RSA_AES256_SHA256 :: Cipher +cipher_DHE_RSA_AES256_SHA256 = cipher_DHE_RSA_AES128_SHA256 + { cipherID = 0x6b + , cipherName = "DHE-RSA-AES256-SHA256" + , cipherBulk = bulk_aes256 + } + + +{- +TLS 1.0 ciphers definition + +CipherSuite TLS_NULL_WITH_NULL_NULL = { 0x00,0x00 }; +CipherSuite TLS_RSA_WITH_NULL_MD5 = { 0x00,0x01 }; +CipherSuite TLS_RSA_WITH_NULL_SHA = { 0x00,0x02 }; +CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x03 }; +CipherSuite TLS_RSA_WITH_RC4_128_MD5 = { 0x00,0x04 }; +CipherSuite TLS_RSA_WITH_RC4_128_SHA = { 0x00,0x05 }; +CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5 = { 0x00,0x06 }; +CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA = { 0x00,0x07 }; +CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x08 }; +CipherSuite TLS_RSA_WITH_DES_CBC_SHA = { 0x00,0x09 }; +CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0A }; +CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0B }; +CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA = { 0x00,0x0C }; +CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0D }; +CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0E }; +CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA = { 0x00,0x0F }; +CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x10 }; +CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 }; +CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA = { 0x00,0x12 }; +CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x13 }; +CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 }; +CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA = { 0x00,0x15 }; +CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x16 }; +CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x17 }; +CipherSuite TLS_DH_anon_WITH_RC4_128_MD5 = { 0x00,0x18 }; +CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 }; +CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA = { 0x00,0x1A }; +CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA = { 0x00,0x1B }; + +TLS-DHE-RSA-WITH-AES-128-CBC-SHA {0x00,0x33} +TLS-DHE-RSA-WITH-AES-256-CBC-SHA {0x00,0x39} +TLS-DHE-RSA-WITH-AES-128-CBC-SHA256 {0x00,0x67} +TLS-DHE-RSA-WITH-AES-256-CBC-SHA256 {0x00,0x6B} +TLS-DHE-RSA-WITH-AES-128-GCM-SHA256 {0x00,0x9E} +TLS-DHE-RSA-WITH-AES-256-GCM-SHA384 {0x00,0x9F} +TLS-DHE-RSA-WITH-CAMELLIA-128-CBC-SHA {0x00,0x45} +TLS-DHE-RSA-WITH-CAMELLIA-256-CBC-SHA {0x00,0x88} +TLS-DHE-RSA-WITH-CAMELLIA-128-CBC-SHA256 {0x00,0xBE} +TLS-DHE-RSA-WITH-CAMELLIA-256-CBC-SHA256 {0x00,0xC4} +TLS-DHE-RSA-WITH-CAMELLIA-128-GCM-SHA256 {0x00,0x7C} +TLS-DHE-RSA-WITH-CAMELLIA-256-GCM-SHA256 {0x00,0x7D} +TLS-DHE-RSA-WITH-3DES-EDE-CBC-SHA {0x00,0x16} +TLS-DHE-RSA-WITH-DES-CBC-SHA {0x00,0x15} + +TLS-ECDHE-RSA-WITH-AES-128-CBC-SHA {0xC0,0x13} +TLS-ECDHE-RSA-WITH-AES-256-CBC-SHA {0xC0,0x14} +TLS-ECDHE-RSA-WITH-AES-128-CBC-SHA256 {0xC0,0x27} +TLS-ECDHE-RSA-WITH-AES-256-CBC-SHA384 {0xC0,0x28} +TLS-ECDHE-RSA-WITH-AES-128-GCM-SHA256 {0xC0,0x2F} +TLS-ECDHE-RSA-WITH-AES-256-GCM-SHA384 {0xC0,0x30} +TLS-ECDHE-RSA-WITH-CAMELLIA-128-CBC-SHA256 {0xC0,0x76} +TLS-ECDHE-RSA-WITH-CAMELLIA-256-CBC-SHA384 {0xC0,0x77} +TLS-ECDHE-RSA-WITH-CAMELLIA-128-GCM-SHA256 {0xC0,0x8A} +TLS-ECDHE-RSA-WITH-CAMELLIA-256-GCM-SHA384 {0xC0,0x8B} +TLS-ECDHE-RSA-WITH-3DES-EDE-CBC-SHA {0xC0,0x12} +TLS-ECDHE-RSA-WITH-RC4-128-SHA {0xC0,0x11} +TLS-ECDHE-RSA-WITH-NULL-SHA {0xC0,0x10} + +TLS-PSK-WITH-RC4-128-SHA {0x00,0x8A} +TLS-PSK-WITH-3DES-EDE-CBC-SHA {0x00,0x8B} +TLS-PSK-WITH-AES-128-CBC-SHA {0x00,0x8C} +TLS-PSK-WITH-AES-256-CBC-SHA {0x00,0x8D} +TLS-PSK-WITH-AES-128-CBC-SHA256 {0x00,0xAE} +TLS-PSK-WITH-AES-256-CBC-SHA384 {0x00,0xAF} +TLS-PSK-WITH-AES-128-GCM-SHA256 {0x00,0xA8} +TLS-PSK-WITH-AES-256-GCM-SHA384 {0x00,0xA9} +TLS-PSK-WITH-CAMELLIA-128-CBC-SHA256 {0xC0,0x94} +TLS-PSK-WITH-CAMELLIA-256-CBC-SHA384 {0xC0,0x95} +TLS-PSK-WITH-CAMELLIA-128-GCM-SHA256 {0xC0,0x8D} +TLS-PSK-WITH-CAMELLIA-256-GCM-SHA384 {0xC0,0x8F} +TLS-PSK-WITH-NULL-SHA {0x00,0x2C} +TLS-PSK-WITH-NULL-SHA256 {0x00,0xB4} +TLS-PSK-WITH-NULL-SHA384 {0x00,0xB5} + +best ciphers suite description: + + +-} diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake -- License : BSD-style @@ -8,14 +7,16 @@ -- module Network.TLS.Handshake ( handshake + , handshakeClientWith , handshakeServerWith , handshakeClient - , HandshakeFailed(..) + , handshakeServer ) where -import Network.TLS.Context +import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.IO +import Network.TLS.Util (catchException) import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client @@ -23,19 +24,14 @@ 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 +handshake ctx = + liftIO $ handleException $ withRWLock ctx (ctxDoHandshake ctx $ ctx) + where handleException f = catchException f $ \exception -> do + let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception + setEstablished ctx False + sendPacket ctx (errorToAlert tlserror) + handshakeFailed tlserror diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -10,8 +10,9 @@ , rejectOnException ) where -import Network.TLS.Context +import Network.TLS.Context.Internal import Network.TLS.Struct +import Network.TLS.X509 import Control.Monad.State import Control.Exception (SomeException) @@ -26,5 +27,5 @@ certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) -rejectOnException :: SomeException -> IO TLSCertificateUsage +rejectOnException :: SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -8,10 +8,12 @@ -- module Network.TLS.Handshake.Client ( handshakeClient + , handshakeClientWith ) where import Network.TLS.Crypto -import Network.TLS.Context +import Network.TLS.Context.Internal +import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.Cipher import Network.TLS.Compression @@ -19,251 +21,315 @@ 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 Network.TLS.Util (bytesEq, catchException) +import Network.TLS.Types +import Network.TLS.X509 import Data.Maybe import Data.List (find) import qualified Data.ByteString as B import Data.ByteString.Char8 () -import Data.Certificate.X509(X509, x509Cert, certPubKey, PubKey(PubKeyRSA)) - -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Monad.State +import Control.Monad.Error import Control.Exception (SomeException) -import qualified Control.Exception as E import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Process import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.State +handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () +handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx +handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure) + -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. -handshakeClient :: MonadIO m => ClientParams -> Context -> m () +handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do updateMeasure ctx incrementNbHandshakes sentExtensions <- sendClientHello recvServerHello sentExtensions sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming - then sendChangeCipherAndFinish ctx True + then sendChangeCipherAndFinish sendMaybeNPN ctx ClientRole else do sendClientData cparams ctx - sendChangeCipherAndFinish ctx True + sendChangeCipherAndFinish sendMaybeNPN ctx ClientRole recvChangeCipherAndFinish ctx handshakeTerminate ctx - where - params = ctxParams ctx - allowedvers = pAllowedVersions params - ciphers = pCiphers params - compressions = pCompressions params - getExtensions = sequence [sniExtension,secureReneg,npnExtention] >>= return . catMaybes - - toExtensionRaw :: Extension e => e -> ExtensionRaw - toExtensionRaw ext = (extensionID ext, extensionEncode ext) - - secureReneg = - if pUseSecureRenegotiation params - then usingState_ ctx (getVerifiedData True) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing - else return Nothing - npnExtention = if isJust $ onNPNServerSuggest params - then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] - else return Nothing - sniExtension = return ((\h -> toExtensionRaw $ ServerName [(ServerNameHostName h)]) <$> clientUseServerName cparams) - sendClientHello = do - crand <- getStateRNG ctx 32 >>= return . ClientRandom - let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams - extensions <- getExtensions - usingState_ ctx (startHandshakeClient (pConnectVersion params) crand) - sendPacket ctx $ Handshake - [ ClientHello (pConnectVersion params) crand clientSession (map cipherID ciphers) - (map compressionID compressions) extensions Nothing - ] - return $ map fst extensions - - expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish - expectChangeCipher p = unexpected (show p) (Just "change cipher") - expectFinish (Finished _) = return RecvStateDone - expectFinish p = unexpected (show p) (Just "Handshake Finished") - - recvServerHello sentExts = runRecvState ctx (RecvStateHandshake $ onServerHello sentExts) - - onServerHello :: MonadIO m => [ExtensionID] -> Handshake -> m (RecvState m) - onServerHello sentExts sh@(ServerHello rver _ serverSession cipher _ exts) = do - when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) - case find ((==) rver) allowedvers of - Nothing -> throwCore $ Error_Protocol ("version " ++ show rver ++ "is not supported", True, ProtocolVersion) - Just _ -> usingState_ ctx $ setVersion rver - case find ((==) cipher . cipherID) ciphers of - Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) - Just c -> usingState_ ctx $ setCipher c - - -- intersect sent extensions in client and the received extensions from server. - -- if server returns extensions that we didn't request, fail. - when (not $ null $ filter (not . flip elem sentExts . fst) exts) $ - throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) - - let resumingSession = case clientWantSessionResume cparams of - Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing - Nothing -> Nothing - usingState_ ctx $ setSession serverSession (isJust resumingSession) - usingState_ ctx $ processServerHello sh - - case extensionDecode False `fmap` (lookup extensionID_NextProtocolNegotiation exts) of - Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do - setExtensionNPN True - setServerNextProtocolSuggest protos - _ -> return () - - case resumingSession of - Nothing -> return $ RecvStateHandshake processCertificate - Just sessionData -> do - usingState_ ctx (setMasterSecret $ sessionSecret sessionData) - return $ RecvStateNext expectChangeCipher - onServerHello _ p = unexpected (show p) (Just "server hello") - - processCertificate :: MonadIO m => Handshake -> m (RecvState m) - processCertificate (Certificates certs) = do - usage <- liftIO $ E.catch (onCertificatesRecv params $ certs) rejectOnException - case usage of - CertificateUsageAccept -> return () - CertificateUsageReject reason -> certificateRejected reason - return $ RecvStateHandshake processServerKeyExchange + where ciphers = ctxCiphers ctx + compressions = supportedCompressions $ ctxSupported ctx + getExtensions = sequence [sniExtension,secureReneg,npnExtention] >>= return . catMaybes - processCertificate p = processServerKeyExchange p + toExtensionRaw :: Extension e => e -> ExtensionRaw + toExtensionRaw ext = (extensionID ext, extensionEncode ext) - processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m) - processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest - processServerKeyExchange p = processCertificateRequest p + secureReneg = + if supportedSecureRenegotiation $ ctxSupported ctx + then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing + else return Nothing + npnExtention = if isJust $ onNPNServerSuggest $ clientHooks cparams + then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] + else return Nothing + sniExtension = if clientUseServerNameIndication cparams + then return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName $ fst $ clientServerIdentification cparams] + else return Nothing + sendClientHello = do + crand <- getStateRNG ctx 32 >>= return . ClientRandom + let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams + highestVer = maximum $ supportedVersions $ ctxSupported ctx + extensions <- getExtensions + startHandshake ctx highestVer crand + usingState_ ctx $ setVersionIfUnset highestVer + sendPacket ctx $ Handshake + [ ClientHello highestVer crand clientSession (map cipherID ciphers) + (map compressionID compressions) extensions Nothing + ] + return $ map fst extensions - 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 + sendMaybeNPN = do + suggest <- usingState_ ctx $ getServerNextProtocolSuggest + case (onNPNServerSuggest $ clientHooks cparams, suggest) of + -- client offered, server picked up. send NPN handshake. + (Just io, Just protos) -> do proto <- liftIO $ io protos + sendPacket ctx (Handshake [HsNextProtocolNegotiation proto]) + usingState_ ctx $ setNegotiatedProtocol proto + -- client offered, server didn't pick up. do nothing. + (Just _, Nothing) -> return () + -- client didn't offer. do nothing. + (Nothing, _) -> return () - processServerHelloDone ServerHelloDone = return RecvStateDone - processServerHelloDone p = unexpected (show p) (Just "server hello data") + recvServerHello sentExts = runRecvState ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) -- | send client Data after receiving all server data (hello/certificates/key). -- -- -> [certificate] -- -> client key exchange -- -> [cert verify] -sendClientData :: MonadIO m => ClientParams -> Context -> m () +sendClientData :: ClientParams -> Context -> IO () sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify - where - -- When the server requests a client certificate, we - -- fetch a certificate chain from the callback in the - -- client parameters and send it to the server. - -- Additionally, we store the private key associated - -- with the first certificate in the chain for later - -- use. - -- - sendCertificate = do - certRequested <- usingState_ ctx getClientCertRequest - case certRequested of - Nothing -> - return () + where + -- When the server requests a client certificate, we + -- fetch a certificate chain from the callback in the + -- client parameters and send it to the server. + -- Additionally, we store the private key associated + -- with the first certificate in the chain for later + -- use. + -- + sendCertificate = do + certRequested <- usingHState ctx getClientCertRequest + case certRequested of + Nothing -> + return () - Just req -> do - certChain <- liftIO $ onCertificateRequest cparams req `E.catch` - throwMiscErrorOnException "certificate request callback failed" + Just req -> do + certChain <- liftIO $ (onCertificateRequest $ clientHooks cparams) req `catchException` + 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 () + usingHState ctx $ setClientCertSent False + case certChain of + Nothing -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])] + Just (CertificateChain [], _) -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])] + Just (cc@(CertificateChain (c:_)), pk) -> do + case certPubKey $ getCertificate c of + PubKeyRSA _ -> return () + _ -> throwCore $ Error_Protocol ("no supported certificate type", True, HandshakeFailure) + usingHState ctx $ setPrivateKey pk + usingHState ctx $ setClientCertSent True + sendPacket ctx $ Handshake [Certificates cc] - usingState_ ctx $ setClientCertSent (not $ null certChain) - sendPacket ctx $ Handshake [Certificates $ map fst certChain] + sendClientKeyXchg = do + cipher <- usingHState ctx getPendingCipher + ckx <- case cipherKeyExchange cipher of + CipherKeyExchange_RSA -> do + clientVersion <- usingHState ctx $ gets hstClientVersion + (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 + let premaster = encodePreMasterSecret clientVersion prerand + usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster + encryptedPreMaster <- do + -- SSL3 implementation generally forget this length field since it's redundant, + -- however TLS10 make it clear that the length field need to be present. + e <- encryptRSA ctx premaster + let extra = if xver < TLS10 + then B.empty + else encodeWord16 $ fromIntegral $ B.length e + return $ extra `B.append` e + return $ CKX_RSA encryptedPreMaster + CipherKeyExchange_DHE_RSA -> getCKX_DHE + CipherKeyExchange_DHE_DSS -> getCKX_DHE + _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure) + sendPacket ctx $ Handshake [ClientKeyXchg ckx] + where getCKX_DHE = do + xver <- usingState_ ctx getVersion + (ServerDHParams dhparams serverDHPub) <- fromJust <$> usingHState ctx (gets hstServerDHParams) + (clientDHPriv, clientDHPub) <- generateDHE ctx dhparams - sendClientKeyXchg = do - encryptedPreMaster <- usingState_ ctx $ do - xver <- stVersion <$> get - prerand <- genTLSRandom 46 - let premaster = encodePreMasterSecret xver prerand - setMasterSecretFromPre premaster + let premaster = dhGetShared dhparams clientDHPriv serverDHPub + usingHState ctx $ setMasterSecretFromPre xver ClientRole 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] + return $ CKX_DH clientDHPub - -- 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. + -- In order to send a proper certificate verify message, + -- we have to do the following: + -- + -- 1. Determine which signing algorithm(s) the server supports + -- (we currently only support RSA). + -- 2. Get the current handshake hash from the handshake state. + -- 3. Sign the handshake hash + -- 4. Send it to the server. + -- + sendCertificateVerify = do + usedVersion <- usingState_ ctx getVersion + + -- Only send a certificate verify message when we + -- have sent a non-empty list of certificates. -- - sendCertificateVerify = do - usedVersion <- usingState_ ctx $ stVersion <$> get + certSent <- usingHState ctx $ getClientCertSent + case certSent of + True -> do + malg <- case usedVersion of + TLS12 -> do + Just (_, Just hashSigs, _) <- usingHState ctx $ getClientCertRequest + let suppHashSigs = supportedHashSignatures $ ctxSupported ctx + hashSigs' = filter (\ a -> a `elem` hashSigs) suppHashSigs - -- 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 + when (null hashSigs') $ + throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure) + return $ Just $ head hashSigs' + _ -> return Nothing - case usedVersion of - SSL3 -> do - Just masterSecret <- usingState_ ctx $ getMasterSecret - let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs) - hsh = HashDescr id id + -- Fetch all handshake messages up to now. + msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages + (hashMethod, toSign) <- prepareCertificateVerifySignatureData ctx usedVersion malg msgs - sigDig <- usingState_ ctx $ signRSA hsh digest - sendPacket ctx $ Handshake [CertVerify Nothing (CertVerifyData sigDig)] + sigDig <- signatureCreate ctx malg hashMethod toSign + sendPacket ctx $ Handshake [CertVerify sigDig] - x | x == TLS10 || x == TLS11 -> do - let hashf bs = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs) - hsh = HashDescr hashf id + _ -> return () - sigDig <- usingState_ ctx $ signRSA hsh msgs - sendPacket ctx $ Handshake [CertVerify Nothing (CertVerifyData sigDig)] +processServerExtension :: (ExtensionID, Bytes) -> TLSSt () +processServerExtension (0xff01, content) = do + cv <- getVerifiedData ClientRole + sv <- getVerifiedData ServerRole + let bs = extensionEncode (SecureRenegotiation cv $ Just sv) + unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) + return () +processServerExtension _ = return () - _ -> 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' +throwMiscErrorOnException :: String -> SomeException -> IO a +throwMiscErrorOnException msg e = + throwCore $ Error_Misc $ msg ++ ": " ++ show e - when (null hashSigs') $ do - throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure) +-- | onServerHello process the ServerHello message on the client. +-- +-- 1) check the version chosen by the server is one allowed by parameters. +-- 2) check that our compression and cipher algorithms are part of the list we sent +-- 3) check extensions received are part of the one we sent +-- 4) process the session parameter to see if the server want to start a new session or can resume +-- 5) process NPN extension +-- 6) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher +-- +onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO) +onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do + when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) + case find ((==) rver) (supportedVersions $ ctxSupported ctx) of + Nothing -> throwCore $ Error_Protocol ("server version " ++ show rver ++ " is not supported", True, ProtocolVersion) + Just _ -> return () + -- find the compression and cipher methods that the server want to use. + cipherAlg <- case find ((==) cipher . cipherID) (ctxCiphers ctx) of + Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure) + Just alg -> return alg + compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of + Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, HandshakeFailure) + Just alg -> return alg - let hashSig = head hashSigs' - hsh <- getHashAndASN1 hashSig + -- 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) - sigDig <- usingState_ ctx $ signRSA hsh msgs + let resumingSession = + case clientWantSessionResume cparams of + Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing + Nothing -> Nothing + usingState_ ctx $ do + setSession serverSession (isJust resumingSession) + mapM_ processServerExtension exts + setVersion rver + usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg - sendPacket ctx $ Handshake [CertVerify (Just hashSig) (CertVerifyData sigDig)] + case extensionDecode False `fmap` (lookup extensionID_NextProtocolNegotiation exts) of + Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do + setExtensionNPN True + setServerNextProtocolSuggest protos + _ -> return () - _ -> return () + case resumingSession of + Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) + Just sessionData -> do + usingHState ctx (setMasterSecret rver ClientRole $ sessionSecret sessionData) + return $ RecvStateNext expectChangeCipher +onServerHello _ _ _ p = unexpected (show p) (Just "server hello") +processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) +processCertificate cparams ctx (Certificates certs) = do + -- run certificate recv hook + ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs) + -- then run certificate validation + usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException + case usage of + CertificateUsageAccept -> return () + CertificateUsageReject reason -> certificateRejected reason + return $ RecvStateHandshake (processServerKeyExchange ctx) + where shared = clientShared cparams + checkCert = (onServerCertificate $ clientHooks cparams) (sharedCAStore shared) + (sharedValidationCache shared) + (clientServerIdentification cparams) + certs +processCertificate _ ctx p = processServerKeyExchange ctx p +expectChangeCipher :: Packet -> IO (RecvState IO) +expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish +expectChangeCipher p = unexpected (show p) (Just "change cipher") -throwMiscErrorOnException :: MonadIO m => String -> SomeException -> m a -throwMiscErrorOnException msg e = - throwCore $ Error_Misc $ msg ++ ": " ++ show e +expectFinish :: Handshake -> IO (RecvState IO) +expectFinish (Finished _) = return RecvStateDone +expectFinish p = unexpected (show p) (Just "Handshake Finished") + +processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) +processServerKeyExchange ctx (ServerKeyXchg skx) = do + cipher <- usingHState ctx getPendingCipher + case (cipherKeyExchange cipher, skx) of + (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> do + doDHESignature dhparams signature SignatureRSA + (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> do + doDHESignature dhparams signature SignatureDSS + (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) + return $ RecvStateHandshake (processCertificateRequest ctx) + where doDHESignature dhparams signature signatureType = do + -- TODO verify DHParams + expectedData <- generateSignedDHParams ctx dhparams + verified <- signatureVerify ctx signatureType expectedData signature + when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for dhparams", True, HandshakeFailure) + usingHState ctx $ setServerDHParams dhparams + +processServerKeyExchange ctx p = processCertificateRequest ctx p + +processCertificateRequest :: Context -> Handshake -> IO (RecvState IO) +processCertificateRequest ctx (CertRequest cTypes sigAlgs dNames) = do + -- When the server requests a client + -- certificate, we simply store the + -- information for later. + -- + usingHState ctx $ setClientCertRequest (cTypes, sigAlgs, dNames) + return $ RecvStateHandshake (processServerHelloDone ctx) +processCertificateRequest ctx p = processServerHelloDone ctx p + +processServerHelloDone :: Context -> Handshake -> IO (RecvState m) +processServerHelloDone _ ServerHelloDone = return RecvStateDone +processServerHelloDone _ p = unexpected (show p) (Just "server hello data") diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Network.TLS.Handshake.Common - ( HandshakeFailed(..) - , handshakeFailed + ( handshakeFailed , errorToAlert , unexpected , newSession @@ -15,24 +14,25 @@ , recvPacketHandshake ) where -import Network.TLS.Context +import Control.Concurrent.MVar + +import Network.TLS.Parameters +import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct import Network.TLS.IO import Network.TLS.State hiding (getNegotiatedProtocol) -import Network.TLS.Receiving +import Network.TLS.Handshake.Process +import Network.TLS.Handshake.State +import Network.TLS.Record.State import Network.TLS.Measurement -import Data.Maybe -import Data.Data +import Network.TLS.Types +import Network.TLS.Cipher +import Network.TLS.Util import Data.ByteString.Char8 () import Control.Monad.State -import Control.Exception (throwIO, Exception()) - -data HandshakeFailed = HandshakeFailed TLSError - deriving (Show,Eq,Typeable) - -instance Exception HandshakeFailed +import Control.Exception (throwIO) handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err @@ -41,83 +41,85 @@ errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] -unexpected :: MonadIO m => String -> Maybe [Char] -> m a +unexpected :: String -> Maybe [Char] -> IO a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) -newSession :: MonadIO m => Context -> m Session +newSession :: Context -> IO Session newSession ctx - | pUseSession $ ctxParams ctx = getStateRNG ctx 32 >>= return . Session . Just - | otherwise = return $ Session Nothing + | supportedSession $ ctxSupported 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 :: Context -> IO () handshakeTerminate ctx = do - session <- usingState_ ctx getSession - -- only callback the session established if we have a session - case session of - Session (Just sessionId) -> do - sessionData <- 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 + session <- usingState_ ctx getSession + -- only callback the session established if we have a session + case session of + Session (Just sessionId) -> do + sessionData <- getSessionData ctx + liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId (fromJust "session-data" sessionData) + _ -> return () + -- forget all handshake data now and reset bytes counters. + liftIO $ modifyMVar_ (ctxHandshake ctx) (return . const Nothing) + updateMeasure ctx resetBytesCounters + -- mark the secure connection up and running. + setEstablished ctx True + return () - cf <- usingState_ ctx $ getHandshakeDigest isClient - sendPacket ctx (Handshake [Finished cf]) - liftIO $ contextFlush ctx +sendChangeCipherAndFinish :: IO () -- ^ message possibly sent between ChangeCipherSpec and Finished. + -> Context + -> Role + -> IO () +sendChangeCipherAndFinish betweenCall ctx role = do + sendPacket ctx ChangeCipherSpec + betweenCall + liftIO $ contextFlush ctx + cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role + sendPacket ctx (Handshake [Finished cf]) + liftIO $ contextFlush ctx -recvChangeCipherAndFinish :: MonadIO m => Context -> m () +recvChangeCipherAndFinish :: Context -> IO () recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher) - where - expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish - expectChangeCipher p = unexpected (show p) (Just "change cipher") - expectFinish (Finished _) = return RecvStateDone - expectFinish p = unexpected (show p) (Just "Handshake Finished") + 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 + RecvStateNext (Packet -> m (RecvState m)) + | RecvStateHandshake (Handshake -> m (RecvState m)) + | RecvStateDone -recvPacketHandshake :: MonadIO m => Context -> m [Handshake] +recvPacketHandshake :: Context -> IO [Handshake] recvPacketHandshake ctx = do - pkts <- recvPacket ctx - case pkts of - Right (Handshake l) -> return l - Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x) - Left err -> throwCore err + 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 :: Context -> RecvState IO -> IO () 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 + where + loop :: RecvState IO -> [Handshake] -> IO (RecvState IO) + loop recvState [] = return recvState + loop (RecvStateHandshake f) (x:xs) = do + nstate <- f x + processHandshake ctx x + loop nstate xs + loop _ _ = unexpected "spurious handshake" Nothing +getSessionData :: Context -> IO (Maybe SessionData) +getSessionData ctx = do + ver <- usingState_ ctx getVersion + mms <- usingHState ctx (gets hstMasterSecret) + tx <- liftIO $ readMVar (ctxTxState ctx) + case mms of + Nothing -> return Nothing + Just ms -> return $ Just $ SessionData + { sessionVersion = ver + , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx + , sessionSecret = ms + } diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Key.hs @@ -0,0 +1,62 @@ +-- | +-- Module : Network.TLS.Handshake.Key +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- functions for RSA operations +-- +module Network.TLS.Handshake.Key + ( encryptRSA + , signRSA + , decryptRSA + , verifyRSA + , generateDHE + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B + +import Network.TLS.Handshake.State +import Network.TLS.State (withRNG, getVersion) +import Network.TLS.Crypto +import Network.TLS.Types +import Network.TLS.Context.Internal + +{- if the RSA encryption fails we just return an empty bytestring, and let the protocol + - fail by itself; however it would be probably better to just report it since it's an internal problem. + -} +encryptRSA :: Context -> ByteString -> IO ByteString +encryptRSA ctx content = do + publicKey <- usingHState ctx getRemotePublicKey + usingState_ ctx $ do + v <- withRNG (\g -> kxEncrypt g publicKey content) + case v of + Left err -> fail ("rsa encrypt failed: " ++ show err) + Right econtent -> return econtent + +signRSA :: Context -> Role -> HashDescr -> ByteString -> IO ByteString +signRSA ctx _ hsh content = do + privateKey <- usingHState ctx getLocalPrivateKey + usingState_ ctx $ do + r <- withRNG (\g -> kxSign g privateKey hsh content) + case r of + Left err -> fail ("rsa sign failed: " ++ show err) + Right econtent -> return econtent + +decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) +decryptRSA ctx econtent = do + privateKey <- usingHState ctx getLocalPrivateKey + usingState_ ctx $ do + ver <- getVersion + let cipher = if ver < TLS10 then econtent else B.drop 2 econtent + withRNG (\g -> kxDecrypt g privateKey cipher) + +verifyRSA :: Context -> Role -> HashDescr -> ByteString -> ByteString -> IO Bool +verifyRSA ctx _ hsh econtent sign = do + publicKey <- usingHState ctx getRemotePublicKey + return $ kxVerify publicKey hsh econtent sign + +generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) +generateDHE ctx dhp = usingState_ ctx $ withRNG $ \rng -> dhGenerateKeyPair rng dhp diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Process.hs @@ -0,0 +1,109 @@ +-- | +-- Module : Network.TLS.Handshake.Process +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- process handshake message received +-- +module Network.TLS.Handshake.Process + ( processHandshake + , startHandshake + , getHandshakeDigest + ) where + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad.Error +import Control.Monad.State (gets) + +import Network.TLS.Types (Role(..), invertRole) +import Network.TLS.Util +import Network.TLS.Packet +import Network.TLS.Struct +import Network.TLS.State +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Handshake.State +import Network.TLS.Handshake.Key +import Network.TLS.Extension +import Data.X509 (CertificateChain(..), Certificate(..), getCertificate) + +processHandshake :: Context -> Handshake -> IO () +processHandshake ctx hs = do + role <- usingState_ ctx isClientContext + case hs of + ClientHello cver ran _ _ _ ex _ -> when (role == ServerRole) $ do + mapM_ (usingState_ ctx . processClientExtension) ex + startHandshake ctx cver ran + Certificates certs -> processCertificates role certs + ClientKeyXchg content -> when (role == ServerRole) $ do + processClientKeyXchg ctx content + HsNextProtocolNegotiation selected_protocol -> + when (role == ServerRole) $ usingState_ ctx $ setNegotiatedProtocol selected_protocol + Finished fdata -> processClientFinished ctx fdata + _ -> return () + let encoded = encodeHandshake hs + when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded + when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ usingHState ctx $ updateHandshakeDigest encoded + where -- secure renegotiation + processClientExtension (0xff01, content) = do + v <- getVerifiedData ClientRole + let bs = extensionEncode (SecureRenegotiation v Nothing) + unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure) + + setSecureRenegotiation True + -- unknown extensions + processClientExtension _ = return () + + processCertificates :: Role -> CertificateChain -> IO () + processCertificates ServerRole (CertificateChain []) = return () + processCertificates ClientRole (CertificateChain []) = + throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure) + processCertificates _ (CertificateChain (c:_)) = + usingHState ctx $ setPublicKey pubkey + where pubkey = certPubKey $ getCertificate c + +-- process the client key exchange message. the protocol expects the initial +-- client version received in ClientHello, not the negotiated version. +-- in case the version mismatch, generate a random master secret +processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO () +processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do + (rver, role, random) <- usingState_ ctx $ do + (,,) <$> getVersion <*> isClientContext <*> genRandom 48 + ePremaster <- decryptRSA ctx encryptedPremaster + usingHState ctx $ do + expectedVer <- gets hstClientVersion + case ePremaster of + Left _ -> setMasterSecretFromPre rver role random + Right premaster -> case decodePreMasterSecret premaster of + Left _ -> setMasterSecretFromPre rver role random + Right (ver, _) + | ver /= expectedVer -> setMasterSecretFromPre rver role random + | otherwise -> setMasterSecretFromPre rver role premaster +processClientKeyXchg ctx (CKX_DH clientDHValue) = do + rver <- usingState_ ctx getVersion + role <- usingState_ ctx isClientContext + + (ServerDHParams dhparams _) <- fromJust "server dh params" <$> usingHState ctx (gets hstServerDHParams) + dhpriv <- fromJust "dh private" <$> usingHState ctx (gets hstDHPrivate) + let premaster = dhGetShared dhparams dhpriv clientDHValue + usingHState ctx $ setMasterSecretFromPre rver role premaster + +processClientFinished :: Context -> FinishedData -> IO () +processClientFinished ctx fdata = do + (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion + expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc + when (expected /= fdata) $ do + throwCore $ Error_Protocol("bad record mac", True, BadRecordMac) + usingState_ ctx $ updateVerifiedData ServerRole fdata + return () + +startHandshake :: Context -> Version -> ClientRandom -> IO () +startHandshake ctx ver crand = do + -- FIXME check if handshake is already not null + liftIO $ modifyMVar_ (ctxHandshake ctx) $ \hs -> + case hs of + Nothing -> return $ Just $ newEmptyHandshake ver crand + Just _ -> return hs diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -11,32 +11,34 @@ , handshakeServerWith ) where -import Network.TLS.Crypto -import Network.TLS.Context +import Network.TLS.Parameters +import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct import Network.TLS.Cipher import Network.TLS.Compression -import Network.TLS.Packet +import Network.TLS.Credentials import Network.TLS.Extension +import Network.TLS.Util (catchException, fromJust) import Network.TLS.IO +import Network.TLS.Types import Network.TLS.State hiding (getNegotiatedProtocol) -import Network.TLS.Receiving +import Network.TLS.Handshake.State +import Network.TLS.Handshake.Process +import Network.TLS.Handshake.Key import Network.TLS.Measurement -import Data.Maybe -import Data.List (intersect) +import Data.Maybe (isJust) +import Data.List (intersect, sortBy) 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 +import Network.TLS.X509 -- Put the server context in handshake mode. -- @@ -45,11 +47,11 @@ -- 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) +handshakeServer sparams ctx = liftIO $ do + hss <- recvPacketHandshake ctx + case hss of + [ch] -> handshakeServerWith sparams ctx ch + _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss) -- | Put the server context in handshake mode. -- @@ -76,132 +78,182 @@ -- -> 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 +handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () +handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientSession ciphers compressions exts _) = do + -- check if policy allow this new handshake to happens + handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) + unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") + updateMeasure ctx incrementNbHandshakes - -- Handle Client hello - usingState_ ctx $ processHandshake clientHello - when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) - when (not $ elem ver (pAllowedVersions params)) $ - throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) - when (commonCipherIDs == []) $ - throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) - when (null commonCompressions) $ - throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) - usingState_ ctx $ modify (\st -> st - { stVersion = ver - , stPendingCipher = Just usedCipher - , stCompression = usedCompression - }) + -- Handle Client hello + processHandshake ctx clientHello - 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 (clientVersion == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) + chosenVersion <- case findHighestVersionFrom clientVersion (supportedVersions $ ctxSupported ctx) of + Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion) + Just v -> return v - --- + when (commonCipherIDs == []) $ throwCore $ + Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) + when (null commonCompressions) $ throwCore $ + Error_Protocol ("no compression in common with the client", True, HandshakeFailure) - -- When the client sends a certificate, check whether - -- it is acceptable for the application. - -- - --- + let ciphersFilteredVersion = filter (cipherAllowedForVersion chosenVersion) commonCiphers + usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion + creds = sharedCredentials $ ctxShared ctx + cred <- case cipherKeyExchange usedCipher of + CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds + CipherKeyExchange_DH_Anon -> return $ Nothing + CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds + CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning SignatureDSS creds + _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) - makeServerHello session = do - srand <- getStateRNG ctx 32 >>= return . ServerRandom - case privKeys of - (Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey - _ -> return () -- return a sensible error + resumeSessionData <- case clientSession of + (Session (Just clientSessionId)) -> liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId + (Session Nothing) -> return Nothing - -- 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 + doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts - 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]) + where + commonCipherIDs = intersect ciphers (map cipherID $ ctxCiphers ctx) + commonCiphers = filter (flip elem commonCipherIDs . cipherID) (ctxCiphers ctx) + commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions + usedCompression = head commonCompressions - -- 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]) +handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) - -- Send HelloDone - sendPacket ctx (Handshake [ServerHelloDone]) +doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher + -> Compression -> Session -> Maybe SessionData + -> [(ExtensionID, a)] -> IO () +doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do + case resumeSessionData of + Nothing -> do + handshakeSendServerData + liftIO $ contextFlush ctx + -- Receive client info until client Finished. + recvClientData sparams ctx + sendChangeCipherAndFinish (return ()) ctx ServerRole + Just sessionData -> do + usingState_ ctx (setSession clientSession True) + serverhello <- makeServerHello clientSession + sendPacket ctx $ Handshake [serverhello] + usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData + sendChangeCipherAndFinish (return ()) ctx ServerRole + recvChangeCipherAndFinish ctx + handshakeTerminate ctx + where + clientRequestedNPN = isJust $ lookup extensionID_NextProtocolNegotiation exts - extractCAname :: X509 -> DistinguishedName - extractCAname cert = certSubjectDN (x509Cert cert) + --- + -- When the client sends a certificate, check whether + -- it is acceptable for the application. + -- + --- + makeServerHello session = do + srand <- getStateRNG ctx 32 >>= return . ServerRandom + case mcred of + Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey + _ -> return () -- return a sensible error -handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello" + -- in TLS12, we need to check as well the certificates we are sending if they have in the extension + -- the necessary bits set. + secReneg <- usingState_ ctx getSecureRenegotiation + secRengExt <- if secReneg + then do + vf <- usingState_ ctx $ do + cvf <- getVerifiedData ClientRole + svf <- getVerifiedData ServerRole + return $ extensionEncode (SecureRenegotiation cvf $ Just svf) + return [ (0xff01, vf) ] + else return [] + nextProtocols <- + if clientRequestedNPN + then liftIO $ onSuggestNextProtocols $ serverHooks sparams + 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 chosenVersion) + usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression + return $ ServerHello chosenVersion srand session (cipherID usedCipher) + (compressionID usedCompression) extensions + handshakeSendServerData = do + serverSession <- newSession ctx + usingState_ ctx (setSession serverSession False) + serverhello <- makeServerHello serverSession + -- send ServerHello & Certificate & ServerKeyXchg & CertReq + let certMsg = case mcred of + Just (srvCerts, _) -> Certificates srvCerts + _ -> Certificates $ CertificateChain [] + sendPacket ctx $ Handshake [ serverhello, certMsg ] + + -- send server key exchange if needed + skx <- case cipherKeyExchange usedCipher of + CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon + CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE SignatureRSA + CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE SignatureDSS + _ -> return Nothing + maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx + + -- FIXME we don't do this on a Anonymous server + + -- When configured, send a certificate request + -- with the DNs of all confgure CA + -- certificates. + -- + when (serverWantClientCert sparams) $ do + usedVersion <- usingState_ ctx getVersion + let certTypes = [ CertificateType_RSA_Sign ] + hashSigs = if usedVersion < TLS12 + then Nothing + else Just (supportedHashSignatures $ ctxSupported ctx) + creq = CertRequest certTypes hashSigs + (map extractCAname $ serverCACertificates sparams) + usingHState ctx $ setCertReqSent True + sendPacket ctx (Handshake [creq]) + + -- Send HelloDone + sendPacket ctx (Handshake [ServerHelloDone]) + + extractCAname :: SignedCertificate -> DistinguishedName + extractCAname cert = certSubjectDN $ getCertificate cert + + setup_DHE = do + let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams + (priv, pub) <- generateDHE ctx dhparams + + let serverParams = ServerDHParams dhparams pub + + usingHState ctx $ setServerDHParams serverParams + usingHState ctx $ modify $ \hst -> hst { hstDHPrivate = Just priv } + return (serverParams) + + generateSKX_DHE sigAlg = do + serverParams <- setup_DHE + signatureData <- generateSignedDHParams ctx serverParams + + usedVersion <- usingState_ ctx getVersion + let mhash = case usedVersion of + TLS12 -> case filter ((==) sigAlg . snd) $ supportedHashSignatures $ ctxSupported ctx of + [] -> error ("no hash signature for " ++ show sigAlg) + x:_ -> Just (fst x) + _ -> Nothing + let hashDescr = signatureHashData sigAlg mhash + signed <- signatureCreate ctx (fmap (\h -> (h, sigAlg)) mhash) hashDescr signatureData + + case sigAlg of + SignatureRSA -> return $ SKX_DHE_RSA serverParams signed + SignatureDSS -> return $ SKX_DHE_DSS serverParams signed + _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg) + + generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE + -- | receive Client data in handshake until the Finished handshake. -- -- <- [certificate] @@ -211,109 +263,106 @@ -- <- [NPN] -- <- finish -- -recvClientData :: MonadIO m => ServerParams -> Context -> m () +recvClientData :: ServerParams -> Context -> IO () 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 + where processClientCertificate (Certificates certs) = do + -- run certificate recv hook + ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs) + -- Call application callback to see whether the + -- certificate chain is acceptable. + -- + usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException + case usage of + CertificateUsageAccept -> return () + CertificateUsageReject reason -> certificateRejected reason - -- FIXME: We should check whether the certificate - -- matches our request and that we support - -- verifying with that certificate. + -- Remember cert chain for later use. + -- + usingHState ctx $ setClientCertChain certs - return $ RecvStateHandshake processClientKeyExchange + -- FIXME: We should check whether the certificate + -- matches our request and that we support + -- verifying with that certificate. - processClientCertificate p = processClientKeyExchange p + return $ RecvStateHandshake processClientKeyExchange - processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify - processClientKeyExchange p = unexpected (show p) (Just "client key exchange") + processClientCertificate p = processClientKeyExchange p - -- 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) + processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify + processClientKeyExchange p = unexpected (show p) (Just "client key exchange") - -- Fetch all handshake messages up to now. - msgs <- usingState_ ctx $ B.concat <$> getHandshakeMessages + -- Check whether the client correctly signed the handshake. + -- If not, ask the application on how to proceed. + -- + processCertificateVerify (Handshake [hs@(CertVerify dsig@(DigitallySigned mbHashSig _))]) = do + processHandshake ctx hs - usedVersion <- usingState_ ctx $ stVersion <$> get + checkValidClientCertChain "change cipher message expected" - (signature, hsh) <- case usedVersion of - SSL3 -> do - Just masterSecret <- usingState_ ctx $ getMasterSecret - let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs) - hsh = HashDescr id id - return (digest, hsh) + usedVersion <- usingState_ ctx getVersion + -- Fetch all handshake messages up to now. + msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages + (hashMethod, toVerify) <- prepareCertificateVerifySignatureData ctx usedVersion mbHashSig msgs - x | x == TLS10 || x == TLS11 -> do - let hashf bs' = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs') - hsh = HashDescr hashf id - return (msgs,hsh) - _ -> do - let Just sentHashSig = mbHashSig - hsh <- getHashAndASN1 sentHashSig - return (msgs,hsh) + -- Verify the signature. + verif <- signatureVerifyWithHashDescr ctx SignatureRSA hashMethod toVerify dsig - -- Verify the signature. - verif <- usingState_ ctx $ verifyRSA hsh signature bs + case verif of + True -> do + -- When verification succeeds, commit the + -- client certificate chain to the context. + -- + Just certs <- usingHState ctx $ getClientCertChain + usingState_ ctx $ setClientCertificateChain certs + return () - case verif of - True -> do - -- When verification succeeds, commit the - -- client certificate chain to the context. - -- - Just certs <- usingState_ ctx $ getClientCertChain + False -> do + -- Either verification failed because of an + -- invalid format (with an error message), or + -- the signature is wrong. In either case, + -- ask the application if it wants to + -- proceed, we will do that. + res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) + if res + then do + -- When verification fails, but the + -- application callbacks accepts, we + -- also commit the client certificate + -- chain to the context. + Just certs <- usingHState ctx $ getClientCertChain usingState_ ctx $ setClientCertificateChain certs - return () + else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) + return $ RecvStateNext expectChangeCipher - False -> do - -- Either verification failed because of an - -- invalid format (with an error message), or - -- the signature is wrong. In either case, - -- ask the application if it wants to - -- proceed, we will do that. - res <- liftIO $ onUnverifiedClientCert sparams - if res - then do - -- When verification fails, but the - -- application callbacks accepts, we - -- also commit the client certificate - -- chain to the context. - Just certs <- usingState_ ctx $ getClientCertChain - usingState_ ctx $ setClientCertificateChain certs - else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) - return $ RecvStateNext expectChangeCipher + processCertificateVerify p = do + chain <- usingHState ctx $ getClientCertChain + case chain of + Just cc | isNullCertificateChain cc -> return () + | otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage) + Nothing -> return () + expectChangeCipher p - 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") - 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") - 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") - expectFinish (Finished _) = return RecvStateDone - expectFinish p = unexpected (show p) (Just "Handshake Finished") + checkValidClientCertChain msg = do + chain <- usingHState ctx $ getClientCertChain + let throwerror = Error_Protocol (msg , True, UnexpectedMessage) + case chain of + Nothing -> throwCore throwerror + Just cc | isNullCertificateChain cc -> throwCore throwerror + | otherwise -> return () + +findHighestVersionFrom :: Version -> [Version] -> Maybe Version +findHighestVersionFrom clientVersion allowedVersions = + case filter (clientVersion >=) $ reverse $ sortBy compare allowedVersions of + [] -> Nothing + v:_ -> Just v diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -8,17 +8,29 @@ -- module Network.TLS.Handshake.Signature ( getHashAndASN1 + , prepareCertificateVerifySignatureData + , signatureHashData + , signatureCreate + , signatureVerify + , signatureVerifyWithHashDescr + , generateSignedDHParams ) where import Crypto.PubKey.HashDescr -import Network.TLS.Context +import Network.TLS.Crypto +import Network.TLS.Context.Internal import Network.TLS.Struct +import Network.TLS.Packet (generateCertificateVerify_SSL, encodeSignedDHParams) +import Network.TLS.State +import Network.TLS.Handshake.State +import Network.TLS.Handshake.Key +import Network.TLS.Util +import Control.Applicative import Control.Monad.State getHashAndASN1 :: MonadIO m => (HashAlgorithm, SignatureAlgorithm) -> m HashDescr -getHashAndASN1 hashSig = do - case hashSig of +getHashAndASN1 hashSig = case hashSig of (HashSHA1, SignatureRSA) -> return hashDescrSHA1 (HashSHA224, SignatureRSA) -> return hashDescrSHA224 (HashSHA256, SignatureRSA) -> return hashDescrSHA256 @@ -26,4 +38,72 @@ (HashSHA512, SignatureRSA) -> return hashDescrSHA512 _ -> throwCore $ Error_Misc "unsupported hash/sig algorithm" +prepareCertificateVerifySignatureData :: Context + -> Version + -> Maybe HashAndSignatureAlgorithm + -> Bytes + -> IO (HashDescr, Bytes) +prepareCertificateVerifySignatureData ctx usedVersion malg msgs + | usedVersion == SSL3 = do + Just masterSecret <- usingHState ctx $ gets hstMasterSecret + let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs) + hsh = HashDescr id id + return (hsh, digest) + | usedVersion == TLS10 || usedVersion == TLS11 = do + let hashf bs = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs) + hsh = HashDescr hashf id + return (hsh, msgs) + | otherwise = do + let Just hashSig = malg + hsh <- getHashAndASN1 hashSig + return (hsh, msgs) +signatureHashData :: SignatureAlgorithm -> Maybe HashAlgorithm -> HashDescr +signatureHashData SignatureRSA mhash = + case mhash of + Just HashSHA512 -> hashDescrSHA512 + Just HashSHA256 -> hashDescrSHA256 + Just HashSHA1 -> hashDescrSHA1 + Nothing -> HashDescr (hashFinal . hashUpdate (hashInit hashMD5SHA1)) id + _ -> error ("unimplemented signature hash type") +signatureHashData SignatureDSS mhash = + case mhash of + Nothing -> hashDescrSHA1 + Just HashSHA1 -> hashDescrSHA1 + Just _ -> error "invalid DSA hash choice, only SHA1 allowed" +signatureHashData sig _ = error ("unimplemented signature type: " ++ show sig) + +signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> HashDescr -> Bytes -> IO DigitallySigned +signatureCreate ctx malg hashMethod toSign = do + cc <- usingState_ ctx $ isClientContext + DigitallySigned malg <$> signRSA ctx cc hashMethod toSign + +signatureVerify :: Context -> SignatureAlgorithm -> Bytes -> DigitallySigned -> IO Bool +signatureVerify ctx sigAlgExpected toVerify digSig@(DigitallySigned hashSigAlg _) = do + usedVersion <- usingState_ ctx getVersion + let hashDescr = case (usedVersion, hashSigAlg) of + (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" + (TLS12, Just (h,s)) | s == sigAlgExpected -> signatureHashData sigAlgExpected (Just h) + | otherwise -> error "expecting different signature algorithm" + (_, Nothing) -> signatureHashData sigAlgExpected Nothing + (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" + signatureVerifyWithHashDescr ctx sigAlgExpected hashDescr toVerify digSig + +signatureVerifyWithHashDescr :: Context + -> SignatureAlgorithm + -> HashDescr + -> Bytes + -> DigitallySigned + -> IO Bool +signatureVerifyWithHashDescr ctx sigAlgExpected hashDescr toVerify (DigitallySigned _ bs) = do + cc <- usingState_ ctx $ isClientContext + case sigAlgExpected of + SignatureRSA -> verifyRSA ctx cc hashDescr toVerify bs + SignatureDSS -> verifyRSA ctx cc hashDescr toVerify bs + _ -> error "not implemented yet" + +generateSignedDHParams :: Context -> ServerDHParams -> IO Bytes +generateSignedDHParams ctx serverParams = do + (cran, sran) <- usingHState ctx $ do + (,) <$> gets hstClientRandom <*> (fromJust "server random" <$> gets hstServerRandom) + return $ encodeSignedDHParams cran sran serverParams diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/State.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +-- | +-- Module : Network.TLS.Handshake.State +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake.State + ( HandshakeState(..) + , ClientCertRequestData + , HandshakeM + , newEmptyHandshake + , runHandshake + -- * key accessors + , setPublicKey + , setPrivateKey + , getLocalPrivateKey + , getRemotePublicKey + , setServerDHParams + -- * cert accessors + , setClientCertSent + , getClientCertSent + , setCertReqSent + , getCertReqSent + , setClientCertChain + , getClientCertChain + , setClientCertRequest + , getClientCertRequest + -- * digest accessors + , addHandshakeMessage + , updateHandshakeDigest + , getHandshakeMessages + , getHandshakeDigest + -- * master secret + , setMasterSecret + , setMasterSecretFromPre + -- * misc accessor + , getPendingCipher + , setServerHelloParameters + ) where + +import Network.TLS.Util +import Network.TLS.Struct +import Network.TLS.Record.State +import Network.TLS.Packet +import Network.TLS.Crypto +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Types +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.State +import Data.X509 (CertificateChain) + +data HandshakeKeyState = HandshakeKeyState + { hksRemotePublicKey :: !(Maybe PubKey) + , hksLocalPrivateKey :: !(Maybe PrivKey) + } deriving (Show) + +data HandshakeState = HandshakeState + { hstClientVersion :: !(Version) + , hstClientRandom :: !ClientRandom + , hstServerRandom :: !(Maybe ServerRandom) + , hstMasterSecret :: !(Maybe Bytes) + , hstKeyState :: !HandshakeKeyState + , hstServerDHParams :: !(Maybe ServerDHParams) + , hstDHPrivate :: !(Maybe DHPrivate) + , hstHandshakeDigest :: !(Either [Bytes] HashCtx) + , hstHandshakeMessages :: [Bytes] + , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received + , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent + , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent + , hstClientCertChain :: !(Maybe CertificateChain) + , hstPendingTxState :: Maybe RecordState + , hstPendingRxState :: Maybe RecordState + , hstPendingCipher :: Maybe Cipher + , hstPendingCompression :: Compression + } deriving (Show) + +type ClientCertRequestData = ([CertificateType], + Maybe [(HashAlgorithm, SignatureAlgorithm)], + [DistinguishedName]) + +newtype HandshakeM a = HandshakeM { runHandshakeM :: State HandshakeState a } + deriving (Functor, Applicative, Monad) + +instance MonadState HandshakeState HandshakeM where + put x = HandshakeM (put x) + get = HandshakeM (get) +#if MIN_VERSION_mtl(2,1,0) + state f = HandshakeM (state f) +#endif + +-- create a new empty handshake state +newEmptyHandshake :: Version -> ClientRandom -> HandshakeState +newEmptyHandshake ver crand = HandshakeState + { hstClientVersion = ver + , hstClientRandom = crand + , hstServerRandom = Nothing + , hstMasterSecret = Nothing + , hstKeyState = HandshakeKeyState Nothing Nothing + , hstServerDHParams = Nothing + , hstDHPrivate = Nothing + , hstHandshakeDigest = Left [] + , hstHandshakeMessages = [] + , hstClientCertRequest = Nothing + , hstClientCertSent = False + , hstCertReqSent = False + , hstClientCertChain = Nothing + , hstPendingTxState = Nothing + , hstPendingRxState = Nothing + , hstPendingCipher = Nothing + , hstPendingCompression = nullCompression + } + +runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) +runHandshake hst f = runState (runHandshakeM f) hst + +setPublicKey :: PubKey -> HandshakeM () +setPublicKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) }) + where setPK hks = hks { hksRemotePublicKey = Just pk } + +setPrivateKey :: PrivKey -> HandshakeM () +setPrivateKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) }) + where setPK hks = hks { hksLocalPrivateKey = Just pk } + +getRemotePublicKey :: HandshakeM PubKey +getRemotePublicKey = fromJust "remote public key" <$> gets (hksRemotePublicKey . hstKeyState) + +getLocalPrivateKey :: HandshakeM PrivKey +getLocalPrivateKey = fromJust "local private key" <$> gets (hksLocalPrivateKey . hstKeyState) + +setServerDHParams :: ServerDHParams -> HandshakeM () +setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) + +setCertReqSent :: Bool -> HandshakeM () +setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b }) + +getCertReqSent :: HandshakeM Bool +getCertReqSent = gets hstCertReqSent + +setClientCertSent :: Bool -> HandshakeM () +setClientCertSent b = modify (\hst -> hst { hstClientCertSent = b }) + +getClientCertSent :: HandshakeM Bool +getClientCertSent = gets hstClientCertSent + +setClientCertChain :: CertificateChain -> HandshakeM () +setClientCertChain b = modify (\hst -> hst { hstClientCertChain = Just b }) + +getClientCertChain :: HandshakeM (Maybe CertificateChain) +getClientCertChain = gets hstClientCertChain + +setClientCertRequest :: ClientCertRequestData -> HandshakeM () +setClientCertRequest d = modify (\hst -> hst { hstClientCertRequest = Just d }) + +getClientCertRequest :: HandshakeM (Maybe ClientCertRequestData) +getClientCertRequest = gets hstClientCertRequest + +getPendingCipher :: HandshakeM Cipher +getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher + +addHandshakeMessage :: Bytes -> HandshakeM () +addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = content : hstHandshakeMessages hs} + +getHandshakeMessages :: HandshakeM [Bytes] +getHandshakeMessages = gets (reverse . hstHandshakeMessages) + +updateHandshakeDigest :: Bytes -> HandshakeM () +updateHandshakeDigest content = modify $ \hs -> hs + { hstHandshakeDigest = case hstHandshakeDigest hs of + Left bytes -> Left (content:bytes) + Right hashCtx -> Right $ hashUpdate hashCtx content } + +getHandshakeDigest :: Version -> Role -> HandshakeM Bytes +getHandshakeDigest ver role = gets gen + where gen hst = case hstHandshakeDigest hst of + Right hashCtx -> + let msecret = fromJust "master secret" $ hstMasterSecret hst + in generateFinish ver msecret hashCtx + Left _ -> + error "un-initialized handshake digest" + generateFinish | role == ClientRole = generateClientFinished + | otherwise = generateServerFinished + +-- | Generate the master secret from the pre master secret. +setMasterSecretFromPre :: Version -- ^ chosen transmission version + -> Role -- ^ the role (Client or Server) of the generating side + -> Bytes -- ^ the pre master secret + -> HandshakeM () +setMasterSecretFromPre ver role premasterSecret = do + secret <- genSecret <$> get + setMasterSecret ver role secret + where genSecret hst = generateMasterSecret ver + premasterSecret + (hstClientRandom hst) + (fromJust "server random" $ hstServerRandom hst) + +-- | Set master secret and as a side effect generate the key block +-- with all the right parameters, and setup the pending tx/rx state. +setMasterSecret :: Version -> Role -> Bytes -> HandshakeM () +setMasterSecret ver role masterSecret = modify $ \hst -> + let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role + in hst { hstMasterSecret = Just masterSecret + , hstPendingTxState = Just pendingTx + , hstPendingRxState = Just pendingRx } + +computeKeyBlock :: HandshakeState -> Bytes -> Version -> Role -> (RecordState, RecordState) +computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx) + where cipher = fromJust "cipher" $ hstPendingCipher hst + keyblockSize = cipherKeyBlockSize cipher + + bulk = cipherBulk cipher + digestSize = hashSize $ cipherHash cipher + keySize = bulkKeySize bulk + ivSize = bulkIVSize bulk + kb = generateKeyBlock ver (hstClientRandom hst) + (fromJust "server random" $ hstServerRandom hst) + masterSecret keyblockSize + + (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = + fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) + + cstClient = CryptState { cstKey = cWriteKey + , cstIV = cWriteIV + , cstMacSecret = cMACSecret } + cstServer = CryptState { cstKey = sWriteKey + , cstIV = sWriteIV + , cstMacSecret = sMACSecret } + msClient = MacState { msSequence = 0 } + msServer = MacState { msSequence = 0 } + + pendingTx = RecordState + { stCryptState = if cc == ClientRole then cstClient else cstServer + , stMacState = if cc == ClientRole then msClient else msServer + , stCipher = Just cipher + , stCompression = hstPendingCompression hst + } + pendingRx = RecordState + { stCryptState = if cc == ClientRole then cstServer else cstClient + , stMacState = if cc == ClientRole then msServer else msClient + , stCipher = Just cipher + , stCompression = hstPendingCompression hst + } + +setServerHelloParameters :: Version -- ^ chosen version + -> ServerRandom + -> Cipher + -> Compression + -> HandshakeM () +setServerHelloParameters ver sran cipher compression = do + modify $ \hst -> hst + { hstServerRandom = Just sran + , hstPendingCipher = Just cipher + , hstPendingCompression = compression + , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst + } + where initCtx = if ver < TLS12 then hashMD5SHA1 else hashSHA256 + updateDigest (Left bytes) = Right $ foldl hashUpdate initCtx $ reverse bytes + updateDigest (Right _) = error "cannot initialize digest with another digest" diff --git a/Network/TLS/Hooks.hs b/Network/TLS/Hooks.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Hooks.hs @@ -0,0 +1,58 @@ +-- | +-- Module : Network.TLS.Context +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Hooks + ( Logging(..) + , Hooks(..) + , defaultHooks + ) where + +import qualified Data.ByteString as B +import Network.TLS.Struct (Header, Handshake(..)) +import Network.TLS.X509 (CertificateChain) +import Data.Default.Class + +-- | Hooks for logging +-- +-- This is called when sending and receiving packets and IO +data Logging = Logging + { loggingPacketSent :: String -> IO () + , loggingPacketRecv :: String -> IO () + , loggingIOSent :: B.ByteString -> IO () + , loggingIORecv :: Header -> B.ByteString -> IO () + } + +defaultLogging :: Logging +defaultLogging = Logging + { loggingPacketSent = (\_ -> return ()) + , loggingPacketRecv = (\_ -> return ()) + , loggingIOSent = (\_ -> return ()) + , loggingIORecv = (\_ _ -> return ()) + } + +instance Default Logging where + def = defaultLogging + +-- | A collection of hooks actions. +data Hooks = Hooks + { -- | called at each handshake message received + hookRecvHandshake :: Handshake -> IO Handshake + -- | called at each certificate chain message received + , hookRecvCertificates :: CertificateChain -> IO () + -- | hooks on IO and packets, receiving and sending. + , hookLogging :: Logging + } + +defaultHooks :: Hooks +defaultHooks = Hooks + { hookRecvHandshake = \hs -> return hs + , hookRecvCertificates = return . const () + , hookLogging = def + } + +instance Default Hooks where + def = defaultHooks diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -9,51 +9,48 @@ -- module Network.TLS.IO ( checkValid - , ConnectionNotEstablished(..) , sendPacket , recvPacket ) where -import Network.TLS.Context -import Network.TLS.State (needEmptyPacket) +import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet +import Network.TLS.Hooks import Network.TLS.Sending import Network.TLS.Receiving -import Data.Data import qualified Data.ByteString as B import Data.ByteString.Char8 () +import Data.IORef import Control.Monad.State -import Control.Exception (throwIO, Exception()) +import Control.Exception (throwIO) import System.IO.Error (mkIOError, eofErrorType) -data ConnectionNotEstablished = ConnectionNotEstablished - deriving (Show,Eq,Typeable) - -instance Exception ConnectionNotEstablished - -checkValid :: MonadIO m => Context -> m () +checkValid :: Context -> IO () checkValid ctx = do - established <- ctxEstablished ctx - unless established $ liftIO $ throwIO ConnectionNotEstablished - eofed <- ctxEOF ctx - when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing + 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 :: Context -> Int -> IO Bytes readExact ctx sz = do - hdrbs <- liftIO $ contextRecv ctx sz - when (B.length hdrbs < sz) $ do - setEOF ctx - if B.null hdrbs - then throwCore Error_EOF - else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) - return hdrbs + hdrbs <- liftIO $ contextRecv ctx sz + when (B.length hdrbs < sz) $ do + setEOF ctx + if B.null hdrbs + then throwCore Error_EOF + else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) + return hdrbs -recvRecord :: MonadIO m => Bool -- ^ flag to enable SSLv2 compat ClientHello reception - -> Context -- ^ TLS context - -> m (Either TLSError (Record Plaintext)) +-- | recvRecord receive a full TLS record (header + data), from the other side. +-- +-- The record is disengaged from the record layer +recvRecord :: Bool -- ^ flag to enable SSLv2 compat ClientHello reception + -> Context -- ^ TLS context + -> IO (Either TLSError (Record Plaintext)) recvRecord compatSSLv2 ctx #ifdef SSLV2_COMPATIBLE | compatSSLv2 = do @@ -65,51 +62,61 @@ | otherwise = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader where recvLength header@(Header _ _ readlen) | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded - | otherwise = readExact ctx (fromIntegral readlen) >>= makeRecord header + | otherwise = readExact ctx (fromIntegral readlen) >>= getRecord header #ifdef SSLV2_COMPATIBLE recvDeprecatedLength readlen | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do - content <- readExact ctx (fromIntegral readlen) - case decodeDeprecatedHeader readlen content of - Left err -> return $ Left err - Right header -> makeRecord header content + content <- readExact ctx (fromIntegral readlen) + case decodeDeprecatedHeader readlen content of + Left err -> return $ Left err + Right header -> getRecord header content #endif maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) - makeRecord header content = do - liftIO $ (loggingIORecv $ ctxLogging ctx) header content - usingState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) + getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext)) + getRecord header content = do + liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content + runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket :: MonadIO m => Context -> m (Either TLSError Packet) -recvPacket ctx = do - compatSSLv2 <- ctxHasSSLv2ClientHello ctx - erecord <- recvRecord compatSSLv2 ctx - case erecord of - Left err -> return $ Left err - Right record -> do - pkt <- usingState ctx $ processPacket record - case pkt of - Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p - _ -> return () - ctxDisableSSLv2ClientHello ctx - return pkt +recvPacket ctx = liftIO $ do + compatSSLv2 <- ctxHasSSLv2ClientHello ctx + erecord <- recvRecord compatSSLv2 ctx + case erecord of + Left err -> return $ Left err + Right record -> do + pktRecv <- processPacket ctx record + pkt <- case pktRecv of + Right (Handshake hss) -> + ctxWithHooks ctx $ \hooks -> + (mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake + _ -> return pktRecv + case pkt of + Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p + _ -> return () + when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx + return pkt -- | Send one packet to the context sendPacket :: MonadIO m => Context -> Packet -> m () sendPacket ctx pkt = do - -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed - -- by an attacker. Hence, an empty packet is sent before a normal data packet, to - -- prevent guessability. - withEmptyPacket <- usingState_ ctx needEmptyPacket - when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty + -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed + -- by an attacker. Hence, an empty packet is sent before a normal data packet, to + -- prevent guessability. + withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx + when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty - 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 + edataToSend <- liftIO $ do + withLog ctx $ \logging -> loggingPacketSent logging (show pkt) + writePacket ctx pkt + case edataToSend of + Left err -> throwCore err + Right dataToSend -> liftIO $ do + withLog ctx $ \logging -> loggingIOSent logging dataToSend + contextSend ctx dataToSend + where isNonNullAppData (AppData b) = not $ B.null b + isNonNullAppData _ = False 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 @@ -6,16 +6,16 @@ -- 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 @@ -29,21 +29,18 @@ 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 + 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 @@ -56,12 +53,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 @@ -71,11 +68,10 @@ 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/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -10,102 +10,103 @@ -- with only explicit parameters, no TLS state is involved here. -- module Network.TLS.Packet - ( - -- * params for encoding and decoding - CurrentParams(..) - -- * marshall functions for header messages - , decodeHeader - , decodeDeprecatedHeaderLength - , decodeDeprecatedHeader - , encodeHeader - , encodeHeaderNoVer -- use for SSL3 + ( + -- * params for encoding and decoding + CurrentParams(..) + -- * marshall functions for header messages + , decodeHeader + , decodeDeprecatedHeaderLength + , decodeDeprecatedHeader + , encodeHeader + , encodeHeaderNoVer -- use for SSL3 - -- * marshall functions for alert messages - , decodeAlert - , decodeAlerts - , encodeAlerts + -- * marshall functions for alert messages + , decodeAlert + , decodeAlerts + , encodeAlerts - -- * marshall functions for handshake messages - , decodeHandshakes - , decodeHandshake - , decodeDeprecatedHandshake - , encodeHandshake - , encodeHandshakes - , encodeHandshakeHeader - , encodeHandshakeContent + -- * marshall functions for handshake messages + , decodeHandshakes + , decodeHandshake + , decodeDeprecatedHandshake + , 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 + , encodeSignedDHParams - -- * generate things for packet content - , generateMasterSecret - , generateKeyBlock - , generateClientFinished - , generateServerFinished + -- * generate things for packet content + , generateMasterSecret + , generateKeyBlock + , generateClientFinished + , generateServerFinished - , generateCertificateVerify_SSL - ) where + , generateCertificateVerify_SSL + ) where import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap -import Data.Either (partitionEithers) import Data.Maybe (fromJust) import Data.Word -import Data.Bits ((.|.)) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Monad -import Data.Certificate.X509 (decodeCertificate, encodeCertificate, X509, encodeDN, decodeDN) +import Data.ASN1.Types (fromASN1, toASN1) +import Data.ASN1.Encoding (decodeASN1', encodeASN1') +import Data.ASN1.BinaryEncoding (DER(..)) +import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 data CurrentParams = CurrentParams - { cParamsVersion :: Version -- ^ current protocol version - , cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type - , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension - } deriving (Show,Eq) + { cParamsVersion :: Version -- ^ current protocol version + , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type + , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension + } deriving (Show,Eq) {- marshall helpers -} getVersion :: Get Version getVersion = do - major <- getWord8 - minor <- getWord8 - case verOfNum (major, minor) of - Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) - Just v -> return v + 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 @@ -118,10 +119,10 @@ decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header decodeDeprecatedHeader size = - runGetErr "deprecatedheader" $ do - 1 <- getWord8 - version <- getVersion - return $ Header ProtocolType_DeprecatedHandshake version size + runGetErr "deprecatedheader" $ do + 1 <- getWord8 + version <- getVersion + return $ Header ProtocolType_DeprecatedHandshake version size encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len) @@ -136,74 +137,74 @@ -} 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 liftM ((:) x) getAll +decodeHandshakes b = runGetErr "handshakes" getAll b + where getAll = do + x <- decodeHandshakeHeader + empty <- isEmpty + if empty + then return [x] + else liftM ((:) x) getAll decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr "handshake" $ case ty of - HandshakeType_HelloRequest -> decodeHelloRequest - HandshakeType_ClientHello -> decodeClientHello - HandshakeType_ServerHello -> decodeServerHello - HandshakeType_Certificate -> decodeCertificates - HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp - HandshakeType_CertRequest -> decodeCertRequest cp - HandshakeType_ServerHelloDone -> decodeServerHelloDone - HandshakeType_CertVerify -> decodeCertVerify cp - HandshakeType_ClientKeyXchg -> decodeClientKeyXchg - HandshakeType_Finished -> decodeFinished - HandshakeType_NPN -> do - unless (cParamsSupportNPN cp) $ fail "unsupported handshake type" - decodeNextProtocolNegotiation + HandshakeType_HelloRequest -> decodeHelloRequest + HandshakeType_ClientHello -> decodeClientHello + HandshakeType_ServerHello -> decodeServerHello + HandshakeType_Certificate -> decodeCertificates + HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp + HandshakeType_CertRequest -> decodeCertRequest cp + HandshakeType_ServerHelloDone -> decodeServerHelloDone + HandshakeType_CertVerify -> decodeCertVerify cp + HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp + HandshakeType_Finished -> decodeFinished + HandshakeType_NPN -> do + unless (cParamsSupportNPN cp) $ fail "unsupported handshake type" + decodeNextProtocolNegotiation decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake -decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where - getDeprecated = do - 1 <- getWord8 - ver <- getVersion - cipherSpecLen <- fromEnum <$> getWord16 - sessionIdLen <- fromEnum <$> getWord16 - challengeLen <- fromEnum <$> getWord16 - ciphers <- getCipherSpec cipherSpecLen - session <- getSessionId sessionIdLen - random <- getChallenge challengeLen - let compressions = [0] - return $ ClientHello ver random session ciphers compressions [] (Just b) +decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b + where getDeprecated = do + 1 <- getWord8 + ver <- getVersion + cipherSpecLen <- fromEnum <$> getWord16 + sessionIdLen <- fromEnum <$> getWord16 + challengeLen <- fromEnum <$> getWord16 + ciphers <- getCipherSpec cipherSpecLen + session <- getSessionId sessionIdLen + random <- getChallenge challengeLen + let compressions = [0] + return $ ClientHello ver random session ciphers compressions [] (Just b) getCipherSpec len | len < 3 = return [] getCipherSpec len = do - [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 - ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) + [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 + ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) getSessionId 0 = return $ Session Nothing getSessionId len = Session . Just <$> getBytes len getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 @@ -214,132 +215,123 @@ decodeClientHello :: Get Handshake decodeClientHello = do - ver <- getVersion - random <- getClientRandom32 - session <- getSession - ciphers <- getWords16 - compressions <- getWords8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 - then fmap fromIntegral getWord16 >>= getExtensions - else return [] - return $ ClientHello ver random session ciphers compressions exts Nothing + ver <- getVersion + random <- getClientRandom32 + session <- getSession + ciphers <- getWords16 + compressions <- getWords8 + r <- remaining + exts <- if hasHelloExtensions ver && r > 0 + then fmap fromIntegral getWord16 >>= getExtensions + else return [] + return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake decodeServerHello = do - ver <- getVersion - random <- getServerRandom32 - session <- getSession - cipherid <- getWord16 - compressionid <- getWord8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 - then fmap fromIntegral getWord16 >>= getExtensions - else return [] - return $ ServerHello ver random session cipherid compressionid exts + ver <- getVersion + random <- getServerRandom32 + session <- getSession + cipherid <- getWord16 + compressionid <- getWord8 + r <- remaining + exts <- if hasHelloExtensions ver && r > 0 + then fmap fromIntegral getWord16 >>= getExtensions + else return [] + return $ ServerHello ver random session cipherid compressionid exts decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone decodeCertificates :: Get Handshake decodeCertificates = do - certsRaw <- getWord24 >>= \len -> getList (fromIntegral len) getCertRaw - let (badCerts, certs) = partitionEithers $ map (decodeCertificate . L.fromChunks . (:[])) certsRaw - if not $ null badCerts - then fail ("error certificate parsing: " ++ show badCerts) - else return $ Certificates certs - where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) + certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) + case decodeCertificateChain certsRaw of + Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) + Right cc -> return $ Certificates cc + where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) decodeFinished :: Get Handshake decodeFinished = Finished <$> (remaining >>= getBytes) decodeNextProtocolNegotiation :: Get Handshake decodeNextProtocolNegotiation = do - opaque <- getOpaque8 - _ <- getOpaque8 -- ignore padding - return $ HsNextProtocolNegotiation opaque - -getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm -getSignatureHashAlgorithm = do - h <- fromJust . valToType <$> getWord8 - s <- fromJust . valToType <$> getWord8 - return (h,s) + opaque <- getOpaque8 + _ <- getOpaque8 -- ignore padding + return $ HsNextProtocolNegotiation opaque 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 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)) + 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 + dn <- case decodeASN1' DER dName of + Left e -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e) + Right asn1s -> case fromASN1 asn1s of + Left e -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e) + Right (d,_) -> return d return (2 + B.length dName, dn) - 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) +decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp) -os2ip :: ByteString -> Integer -os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0 +decodeClientKeyXchg :: CurrentParams -> Get Handshake +decodeClientKeyXchg cp = -- case ClientKeyXchg <$> (remaining >>= getBytes) + case cParamsKeyXchgType cp of + Nothing -> error "no client key exchange type" + Just cke -> ClientKeyXchg <$> parseCKE cke + where parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes) + parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic + parseCKE CipherKeyExchange_DHE_DSS = parseClientDHPublic + parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic + parseCKE _ = error "unsupported client key exchange type" + parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16 decodeServerKeyXchg_DH :: Get ServerDHParams -decodeServerKeyXchg_DH = do - p <- getOpaque16 - g <- getOpaque16 - y <- getOpaque16 - return $ ServerDHParams { dh_p = os2ip p, dh_g = os2ip g, dh_Ys = os2ip y } +decodeServerKeyXchg_DH = getServerDHParams decodeServerKeyXchg_RSA :: Get ServerRSAParams -decodeServerKeyXchg_RSA = do - modulus <- getOpaque16 - expo <- getOpaque16 - return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } +decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus + <*> getInteger16 -- exponent 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 +decodeServerKeyXchg cp = + case cParamsKeyXchgType cp of + Just cke -> ServerKeyXchg <$> toCKE cke + Nothing -> error "no server key exchange type" + where toCKE cke = case cke of + CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA + CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH + CipherKeyExchange_DHE_RSA -> do + dhparams <- getServerDHParams + signature <- getDigitallySigned (cParamsVersion cp) + return $ SKX_DHE_RSA dhparams signature + CipherKeyExchange_DHE_DSS -> do + dhparams <- getServerDHParams + signature <- getDigitallySigned (cParamsVersion cp) + return $ SKX_DHE_DSS dhparams signature + _ -> do bs <- remaining >>= getBytes return $ SKX_Unknown bs encodeHandshake :: Handshake -> ByteString encodeHandshake o = - let content = runPut $ encodeHandshakeContent o in - let len = fromIntegral $ B.length content in - let header = case o of - ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message - _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in - B.concat [ header, content ] + let content = runPut $ encodeHandshakeContent o in + let len = fromIntegral $ B.length content in + let header = case o of + ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message + _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in + B.concat [ header, content ] encodeHandshakes :: [Handshake] -> ByteString encodeHandshakes hss = B.concat $ map encodeHandshake hss @@ -350,66 +342,64 @@ encodeHandshakeContent :: Handshake -> Put encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do - putBytes deprecated + putBytes deprecated encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do - putVersion version - putClientRandom32 random - putSession session - putWords16 cipherIDs - putWords8 compressionIDs - putExtensions exts - return () + 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 (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) + where (CertificateChainRaw certs) = encodeCertificateChain cc -encodeHandshakeContent (ClientKeyXchg content) = do - putBytes content +encodeHandshakeContent (ClientKeyXchg ckx) = do + case ckx of + CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster + CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic -encodeHandshakeContent (ServerKeyXchg _) = do - -- FIXME - return () +encodeHandshakeContent (ServerKeyXchg skg) = + case skg of + SKX_RSA _ -> error "encodeHandshakeContent SKX_RSA not implemented" + SKX_DH_Anon params -> putServerDHParams params + SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig + SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig + _ -> error "cannot handle" encodeHandshakeContent (HelloRequest) = return () encodeHandshakeContent (ServerHelloDone) = return () encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do - putWords8 (map valOfType certTypes) - case sigAlgs of - Nothing -> return () - Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l - encodeCertAuthorities certAuthorities - where - -- Convert a distinguished name to its DER encoding. - encodeCA dn = return $ B.concat $ L.toChunks $ encodeDN dn - - -- Encode a list of distinguished names. - encodeCertAuthorities certAuths = do - enc <- mapM encodeCA certAuths - let totLength = sum $ map (((+) 2) . B.length) enc - putWord16 (fromIntegral totLength) - mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc + putWords8 (map valOfType certTypes) + case sigAlgs of + Nothing -> return () + Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l + encodeCertAuthorities certAuthorities + where -- Convert a distinguished name to its DER encoding. + encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn -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 + -- Encode a list of distinguished names. + encodeCertAuthorities certAuths = do + enc <- mapM encodeCA certAuths + let totLength = sum $ map (((+) 2) . B.length) enc + putWord16 (fromIntegral totLength) + mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc +encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned encodeHandshakeContent (Finished opaque) = putBytes opaque encodeHandshakeContent (HsNextProtocolNegotiation protocol) = do - putOpaque8 protocol - putOpaque8 $ B.replicate paddingLen 0 - where paddingLen = 32 - ((B.length protocol + 2) `mod` 32) + 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 @@ -432,26 +422,23 @@ 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 -putCert :: X509 -> Put -putCert cert = putOpaque24 (B.concat $ L.toChunks $ encodeCertificate cert) - getExtensions :: Int -> Get [ExtensionRaw] getExtensions 0 = return [] getExtensions len = do - extty <- getWord16 - extdatalen <- getWord16 - extdata <- getBytes $ fromIntegral extdatalen - extxs <- getExtensions (len - fromIntegral extdatalen - 4) - return $ (extty, extdata) : extxs + extty <- getWord16 + extdatalen <- getWord16 + extdata <- getBytes $ fromIntegral extdatalen + extxs <- getExtensions (len - fromIntegral extdatalen - 4) + return $ (extty, extdata) : extxs putExtension :: ExtensionRaw -> Put putExtension (ty, l) = putWord16 ty >> putOpaque16 l @@ -460,14 +447,44 @@ putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) +getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm +getSignatureHashAlgorithm = do + h <- fromJust . valToType <$> getWord8 + s <- fromJust . valToType <$> getWord8 + return (h,s) + +putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put +putSignatureHashAlgorithm (h,s) = + putWord8 (valOfType h) >> putWord8 (valOfType s) + +getServerDHParams :: Get ServerDHParams +getServerDHParams = ServerDHParams <$> getDHParams <*> getDHPublic + where getDHParams = dhParams <$> getInteger16 -- p + <*> getInteger16 -- g + getDHPublic = dhPublic <$> getInteger16 -- y(server) + +putServerDHParams :: ServerDHParams -> Put +putServerDHParams (ServerDHParams dhparams dhpub) = + mapM_ putInteger16 $ dhUnwrap dhparams dhpub + +getDigitallySigned :: Version -> Get DigitallySigned +getDigitallySigned ver + | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm) + <*> getOpaque16 + | otherwise = DigitallySigned Nothing <$> getOpaque16 + +putDigitallySigned :: DigitallySigned -> Put +putDigitallySigned (DigitallySigned mhash sig) = + maybe (return ()) putSignatureHashAlgorithm mhash >> putOpaque16 sig + {- - decode and encode ALERT -} decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do - x <- getWord8 - when (x /= 1) (fail "unknown change cipher spec content") + x <- getWord8 + when (x /= 1) (fail "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) @@ -475,7 +492,7 @@ -- 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) @@ -487,16 +504,14 @@ 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 @@ -507,15 +522,14 @@ 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 @@ -526,32 +540,34 @@ 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 "" + +encodeSignedDHParams :: ClientRandom -> ServerRandom -> ServerDHParams -> Bytes +encodeSignedDHParams cran sran dhparams = runPut $ + putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Parameters.hs @@ -0,0 +1,243 @@ +-- | +-- Module : Network.TLS.Parameters +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Parameters + ( + ClientParams(..) + , ServerParams(..) + , CommonParams + , ClientHooks(..) + , ServerHooks(..) + , Supported(..) + , Shared(..) + -- * special default + , defaultParamsClient + -- * Parameters + , MaxFragmentEnum(..) + , CertificateUsage(..) + , CertificateRejectReason(..) + ) 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.Measurement +import Network.TLS.Compression +import Network.TLS.Crypto +import Network.TLS.Credentials +import Network.TLS.X509 +import Data.Monoid +import Data.Default.Class +import qualified Data.ByteString as B + +type CommonParams = (Supported, Shared) + +data ClientParams = ClientParams + { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum + -- | Define the name of the server, along with an extra service identification blob. + -- this is important that the hostname part is properly filled for security reason, + -- as it allow to properly associate the remote side with the given certificate + -- during a handshake. + -- + -- The extra blob is useful to differentiate services running on the same host, but that + -- might have different certificates given. It's only used as part of the X509 validation + -- infrastructure. + , clientServerIdentification :: (HostName, Bytes) + -- | Allow the use of the Server Name Indication TLS extension during handshake, which allow + -- the client to specify which host name, it's trying to access. This is useful to distinguish + -- CNAME aliasing (e.g. web virtual host). + , clientUseServerNameIndication :: Bool + -- | try to establish a connection using this session. + , clientWantSessionResume :: Maybe (SessionID, SessionData) + , clientShared :: Shared + , clientHooks :: ClientHooks + , clientSupported :: Supported + } deriving (Show) + +defaultParamsClient :: HostName -> Bytes -> ClientParams +defaultParamsClient serverName serverId = ClientParams + { clientWantSessionResume = Nothing + , clientUseMaxFragmentLength = Nothing + , clientServerIdentification = (serverName, serverId) + , clientUseServerNameIndication = True + , clientShared = def + , clientHooks = def + , clientSupported = def + } + +data ServerParams = ServerParams + { -- | request a certificate from client. + serverWantClientCert :: Bool + + -- | This is a list of certificates from which the + -- disinguished names are sent in certificate request + -- messages. For TLS1.0, it should not be empty. + , serverCACertificates :: [SignedCertificate] + + -- | Server Optional Diffie Hellman parameters. If this value is not + -- properly set, no Diffie Hellman key exchange will take place. + , serverDHEParams :: Maybe DHParams + + , serverShared :: Shared + , serverHooks :: ServerHooks + , serverSupported :: Supported + } deriving (Show) + +defaultParamsServer :: ServerParams +defaultParamsServer = ServerParams + { serverWantClientCert = False + , serverCACertificates = [] + , serverDHEParams = Nothing + , serverHooks = def + , serverShared = def + , serverSupported = def + } + +instance Default ServerParams where + def = defaultParamsServer + +-- | List all the supported algorithms, versions, ciphers, etc supported. +data Supported = Supported + { + -- | Supported Versions by this context + -- On the client side, the highest version will be used to establish the connection. + -- On the server side, the highest version that is less or equal than the client version will be chosed. + supportedVersions :: [Version] + -- | Supported cipher methods + , supportedCiphers :: [Cipher] + -- | supported compressions methods + , supportedCompressions :: [Compression] + -- | All supported hash/signature algorithms pair for client + -- certificate verification, ordered by decreasing priority. + , supportedHashSignatures :: [HashAndSignatureAlgorithm] + -- | Set if we support secure renegotiation. + , supportedSecureRenegotiation :: Bool + -- | Set if we support session. + , supportedSession :: Bool + } deriving (Show,Eq) + +defaultSupported :: Supported +defaultSupported = Supported + { supportedVersions = [TLS10,TLS11,TLS12] + , supportedCiphers = [] + , supportedCompressions = [nullCompression] + , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA) + , (Struct.HashSHA384, SignatureRSA) + , (Struct.HashSHA256, SignatureRSA) + , (Struct.HashSHA224, SignatureRSA) + , (Struct.HashSHA1, SignatureDSS) + ] + , supportedSecureRenegotiation = True + , supportedSession = True + } + +instance Default Supported where + def = defaultSupported + +data Shared = Shared + { sharedCredentials :: Credentials + , sharedSessionManager :: SessionManager + , sharedCAStore :: CertificateStore + , sharedValidationCache :: ValidationCache + } + +instance Show Shared where + show _ = "Shared" +instance Default Shared where + def = Shared + { sharedCAStore = mempty + , sharedCredentials = mempty + , sharedSessionManager = noSessionManager + , sharedValidationCache = def + } + +-- | A set of callbacks run by the clients for various corners of TLS establishment +data ClientHooks = ClientHooks + { -- | This action is called when the server sends a + -- certificate request. The parameter is the information + -- from the request. The action should select a certificate + -- chain of one of the given certificate types where the + -- last certificate in the chain should be signed by one of + -- the given distinguished names. Each certificate should + -- be signed by the following one, except for the last. At + -- least the first of the certificates in the chain must + -- have a corresponding private key, because that is used + -- for signing the certificate verify message. + -- + -- Note that is is the responsibility of this action to + -- select a certificate matching one of the requested + -- certificate types. Returning a non-matching one will + -- lead to handshake failure later. + -- + -- Returning a certificate chain not matching the + -- distinguished names may lead to problems or not, + -- depending whether the server accepts it. + onCertificateRequest :: ([CertificateType], + Maybe [HashAndSignatureAlgorithm], + [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey)) + , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) + , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] + } + +defaultClientHooks :: ClientHooks +defaultClientHooks = ClientHooks + { onCertificateRequest = \ _ -> return Nothing + , onNPNServerSuggest = Nothing + , onServerCertificate = validateDefault + } + +instance Show ClientHooks where + show _ = "ClientHooks" +instance Default ClientHooks where + def = defaultClientHooks + +-- | A set of callbacks run by the server for various corners of the TLS establishment +data ServerHooks = ServerHooks + { + -- | This action is called when a client certificate chain + -- is received from the client. When it returns a + -- CertificateUsageReject value, the handshake is aborted. + onClientCertificate :: CertificateChain -> IO CertificateUsage + + -- | This action is called when the client certificate + -- cannot be verified. A 'Nothing' argument indicates a + -- wrong signature, a 'Just e' message signals a crypto + -- error. + , onUnverifiedClientCert :: IO Bool + + -- | Allow the server to choose the cipher relative to the + -- the client version and the client list of ciphers. + -- + -- This could be useful with old clients and as a workaround + -- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1) + -- + -- The client cipher list cannot be empty. + , onCipherChoosing :: Version -> [Cipher] -> Cipher + + -- | suggested next protocols accoring to the next protocol negotiation extension. + , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) + -- | at each new handshake, we call this hook to see if we allow handshake to happens. + , onNewHandshake :: Measurement -> IO Bool + } + +defaultServerHooks :: ServerHooks +defaultServerHooks = ServerHooks + { onCipherChoosing = \_ -> head + , onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" + , onUnverifiedClientCert = return False + , onSuggestNextProtocols = return Nothing + , onNewHandshake = \_ -> return True + } + +instance Show ServerHooks where + show _ = "ClientHooks" +instance Default ServerHooks where + def = defaultServerHooks diff --git a/Network/TLS/RNG.hs b/Network/TLS/RNG.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/RNG.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes #-} +module Network.TLS.RNG + ( StateRNG(..) + , withTLSRNG + ) where + +import Crypto.Random + +data StateRNG = forall g . CPRG g => StateRNG g + +instance Show StateRNG where + show _ = "rng[..]" + +withTLSRNG :: StateRNG -> (forall g . CPRG g => g -> (a,g)) -> (a, StateRNG) +withTLSRNG (StateRNG rng) f = let (a, rng') = f rng + in (a, StateRNG rng') + diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -8,158 +8,61 @@ -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state -- -module Network.TLS.Receiving (processHandshake, processPacket, processServerHello - , verifyRSA) where +module Network.TLS.Receiving + ( processPacket + ) where -import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Control.Concurrent.MVar -import Network.TLS.Util +import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State +import Network.TLS.Handshake.State import Network.TLS.Cipher -import Network.TLS.Crypto -import Network.TLS.Extension -import Data.Certificate.X509 +import Network.TLS.Util returnEither :: Either TLSError a -> TLSSt a returnEither (Left err) = throwError err returnEither (Right a) = return a -processPacket :: Record Plaintext -> TLSSt Packet +processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) -processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment +processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment -processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) +processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` (decodeAlerts $ fragmentGetBytes fragment)) -processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do - returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment - switchRxEncryption - return ChangeCipherSpec +processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) = + case decodeChangeCipherSpec $ fragmentGetBytes fragment of + Left err -> return $ Left err + Right _ -> do switchRxEncryption ctx + return $ Right ChangeCipherSpec -processPacket (Record ProtocolType_Handshake ver fragment) = do - keyxchg <- getCipherKeyExchangeType +processPacket ctx (Record ProtocolType_Handshake ver fragment) = do + keyxchg <- getHState ctx >>= \hs -> return $ (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) + usingState ctx $ do npn <- getExtensionNPN let currentparams = CurrentParams - { cParamsVersion = ver - , cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg - , cParamsSupportNPN = npn - } + { cParamsVersion = ver + , cParamsKeyXchgType = 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 + case decodeHandshake currentparams ty content of + Left err -> throwError err + Right hs -> return hs return $ Handshake hss -processPacket (Record ProtocolType_DeprecatedHandshake _ fragment) = - case decodeDeprecatedHandshake $ fragmentGetBytes fragment of - Left err -> throwError err - Right hs -> return $ Handshake [hs] - -processHandshake :: Handshake -> TLSSt () -processHandshake hs = do - clientmode <- isClientContext - case hs of - ClientHello cver ran _ _ _ ex _ -> unless clientmode $ do - mapM_ processClientExtension ex - startHandshakeClient cver ran - Certificates certs -> processCertificates clientmode certs - ClientKeyXchg content -> unless clientmode $ do - processClientKeyXchg content - HsNextProtocolNegotiation selected_protocol -> - unless clientmode $ do - setNegotiatedProtocol selected_protocol - Finished fdata -> processClientFinished fdata - _ -> return () - when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage $ encodeHandshake hs - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) - where - -- secure renegotiation - processClientExtension (0xff01, content) = do - v <- getVerifiedData True - let bs = extensionEncode (SecureRenegotiation v Nothing) - unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure) - - setSecureRenegotiation True - -- unknown extensions - processClientExtension _ = return () - -decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) -decryptRSA econtent = do - st <- get - ver <- stVersion <$> get - rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get - let cipher = if ver < TLS10 then econtent else B.drop 2 econtent - let (mmsg,rng') = withTLSRNG (stRandomGen st) (\g -> kxDecrypt g rsapriv cipher) - put (st { stRandomGen = rng' }) - return mmsg - -verifyRSA :: HashDescr -> ByteString -> ByteString -> TLSSt Bool -verifyRSA hsh econtent sign = do - rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get - return $ kxVerify rsapriv hsh econtent sign - -processServerHello :: Handshake -> TLSSt () -processServerHello (ServerHello sver ran _ _ _ ex) = do - -- FIXME notify the user to take action if the extension requested is missing - -- secreneg <- getSecureRenegotiation - -- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ... - mapM_ processServerExtension ex - setServerRandom ran - setVersion sver - where - processServerExtension (0xff01, content) = do - cv <- getVerifiedData True - sv <- getVerifiedData False - let bs = extensionEncode (SecureRenegotiation cv $ Just sv) - unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) - return () - - processServerExtension _ = return () -processServerHello _ = error "processServerHello called on wrong type" - --- process the client key exchange message. the protocol expects the initial --- client version received in ClientHello, not the negotiated version. --- in case the version mismatch, generate a random master secret -processClientKeyXchg :: ByteString -> TLSSt () -processClientKeyXchg encryptedPremaster = do - expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get - random <- genTLSRandom 48 - ePremaster <- decryptRSA encryptedPremaster - case ePremaster of - Left _ -> setMasterSecretFromPre random - Right premaster -> case decodePreMasterSecret premaster of - Left _ -> setMasterSecretFromPre random - Right (ver, _) - | ver /= expectedVer -> setMasterSecretFromPre random - | otherwise -> setMasterSecretFromPre premaster - -processClientFinished :: FinishedData -> TLSSt () -processClientFinished fdata = do - cc <- stClientContext <$> get - expected <- getHandshakeDigest (not cc) - when (expected /= fdata) $ do - throwError $ Error_Protocol("bad record mac", True, BadRecordMac) - updateVerifiedData False fdata - return () +processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) = + case decodeDeprecatedHandshake $ fragmentGetBytes fragment of + Left err -> return $ Left err + Right hs -> return $ Right $ Handshake [hs] -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 () +switchRxEncryption :: Context -> IO () +switchRxEncryption ctx = + usingHState ctx (gets hstPendingRxState) >>= \rx -> + liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) diff --git a/Network/TLS/Record.hs b/Network/TLS/Record.hs --- a/Network/TLS/Record.hs +++ b/Network/TLS/Record.hs @@ -12,21 +12,31 @@ -- higher-level clients. -- module Network.TLS.Record - ( Record(..) - , Fragment - , fragmentGetBytes - , fragmentPlaintext - , fragmentCiphertext - , recordToRaw - , rawToRecord - , recordToHeader - , Plaintext - , Compressed - , Ciphertext - , engageRecord - , disengageRecord - ) where + ( Record(..) + -- * Fragment manipulation types + , Fragment + , fragmentGetBytes + , fragmentPlaintext + , fragmentCiphertext + , recordToRaw + , rawToRecord + , recordToHeader + , Plaintext + , Compressed + , Ciphertext + -- * Engage and disengage from the record layer + , engageRecord + , disengageRecord + -- * State tracking + , RecordM + , runRecordM + , RecordState(..) + , newRecordState + , getRecordVersion + , setRecordIV + ) where import Network.TLS.Record.Types import Network.TLS.Record.Engage import Network.TLS.Record.Disengage +import Network.TLS.Record.State 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 @@ -17,7 +17,7 @@ import Network.TLS.Struct import Network.TLS.Cap -import Network.TLS.State +import Network.TLS.Record.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression @@ -25,59 +25,59 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B -disengageRecord :: Record Ciphertext -> TLSSt (Record Plaintext) +disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext) disengageRecord = decryptRecord >=> uncompressRecord -uncompressRecord :: Record Compressed -> TLSSt (Record Plaintext) +uncompressRecord :: Record Compressed -> RecordM (Record Plaintext) uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes -> - withCompression $ compressionInflate bytes + withCompression $ compressionInflate bytes -decryptRecord :: Record Ciphertext -> TLSSt (Record Compressed) +decryptRecord :: Record Ciphertext -> RecordM (Record Compressed) decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do - st <- get - if stRxEncrypted st - then get >>= decryptData record e - else return e + st <- get + case stCipher st of + Nothing -> return e + _ -> getRecordVersion >>= \ver -> decryptData ver record e st -getCipherData :: Record a -> CipherData -> TLSSt ByteString +getCipherData :: Record a -> CipherData -> RecordM ByteString getCipherData (Record pt ver _) cdata = do - -- check if the MAC is valid. - macValid <- case cipherDataMAC cdata of - Nothing -> return True - Just digest -> do - let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) - expected_digest <- makeDigest 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 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 <- getRecordVersion + let b = B.length pad - 1 + return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) - unless (macValid &&! paddingValid) $ do - throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) + unless (macValid &&! paddingValid) $ do + throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) - return $ cipherDataContent cdata + return $ cipherDataContent cdata -decryptData :: Record Ciphertext -> Bytes -> TLSState -> TLSSt Bytes -decryptData record econtent st = decryptOf (bulkF bulk) - where cipher = fromJust "cipher" $ stActiveRxCipher st - bulk = cipherBulk cipher - cst = fromJust "rx crypt state" $ stActiveRxCryptState st - macSize = hashSize $ cipherHash cipher - writekey = cstKey cst - blockSize = bulkBlockSize bulk - econtentLen = B.length econtent +decryptData :: Version -> Record Ciphertext -> Bytes -> RecordState -> RecordM Bytes +decryptData ver record econtent tst = decryptOf (bulkF bulk) + where cipher = fromJust "cipher" $ stCipher tst + bulk = cipherBulk cipher + cst = stCryptState tst + macSize = hashSize $ cipherHash cipher + writekey = cstKey cst + blockSize = bulkBlockSize bulk + econtentLen = B.length econtent - explicitIV = hasExplicitBlockIV $ stVersion st + explicitIV = hasExplicitBlockIV ver - sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") + sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") - decryptOf :: BulkFunctions -> TLSSt Bytes - decryptOf (BulkBlockF _ decryptF) = do + decryptOf :: BulkFunctions -> RecordM Bytes + decryptOf (BulkBlockF _ decryptF) = do let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) $ sanityCheckError {- update IV -} @@ -85,7 +85,7 @@ then get2 econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk) else return (cstIV cst, econtent) let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent' - put $ st { stActiveRxCryptState = Just $ cst { cstIV = newiv } } + modify $ \txs -> txs { stCryptState = cst { cstIV = newiv } } let content' = decryptF writekey iv econtent' let paddinglength = fromIntegral (B.last content') + 1 @@ -97,19 +97,18 @@ , cipherDataPadding = Just padding } - decryptOf (BulkStreamF initF _ decryptF) = do + decryptOf (BulkStreamF initF _ decryptF) = do when (econtentLen < macSize) $ sanityCheckError - let iv = cstIV cst - let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent + let (content', newiv) = decryptF (if cstIV cst /= B.empty then cstIV cst else initF writekey) econtent {- update Ctx -} let contentlen = B.length content' - macSize (content, mac) <- get2 content' (contentlen, macSize) - put $ st { stActiveRxCryptState = Just $ cst { cstIV = newiv } } + modify $ \txs -> txs { stCryptState = cst { cstIV = newiv } } getCipherData record $ CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Nothing } - get3 s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls - get2 s (d1,d2) = get3 s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) + 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 @@ -15,7 +15,7 @@ import Control.Monad.State import Network.TLS.Cap -import Network.TLS.State +import Network.TLS.Record.State import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression @@ -23,66 +23,62 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B -engageRecord :: Record Plaintext -> TLSSt (Record Ciphertext) +engageRecord :: Record Plaintext -> RecordM (Record Ciphertext) engageRecord = compressRecord >=> encryptRecord -compressRecord :: Record Plaintext -> TLSSt (Record Compressed) +compressRecord :: Record Plaintext -> RecordM (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 - we just return the packet -} -encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext) +encryptRecord :: Record Compressed -> RecordM (Record Ciphertext) encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do - st <- get - if stTxEncrypted st - then encryptContent record bytes - else return bytes + st <- get + case stCipher st of + Nothing -> return bytes + _ -> encryptContent record bytes -encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString +encryptContent :: Record Compressed -> ByteString -> RecordM ByteString encryptContent record content = do - digest <- makeDigest True (recordToHeader record) content - encryptData $ B.concat [content, digest] + digest <- makeDigest (recordToHeader record) content + encryptData $ B.concat [content, digest] -encryptData :: ByteString -> TLSSt ByteString +encryptData :: ByteString -> RecordM ByteString encryptData content = do - st <- get - - let cipher = fromJust "cipher" $ stActiveTxCipher st - let bulk = cipherBulk cipher - let cst = fromJust "tx crypt state" $ stActiveTxCryptState st + tstate <- get + ver <- getRecordVersion - let writekey = cstKey cst + let cipher = fromJust "cipher" $ stCipher tstate + let bulk = cipherBulk cipher + let cst = stCryptState tstate - case bulkF bulk of - BulkBlockF encrypt _ -> do - let blockSize = fromIntegral $ bulkBlockSize bulk - let msg_len = B.length content - let padding = if blockSize > 0 - then - let padbyte = blockSize - (msg_len `mod` blockSize) in - let padbyte' = if padbyte == 0 then blockSize else padbyte in - B.replicate padbyte' (fromIntegral (padbyte' - 1)) - else - B.empty + let writekey = cstKey cst - -- 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 + case bulkF bulk of + BulkBlockF encrypt _ -> do + let blockSize = fromIntegral $ bulkBlockSize bulk + let msg_len = B.length content + let padding = if blockSize > 0 + then + let padbyte = blockSize - (msg_len `mod` blockSize) in + let padbyte' = if padbyte == 0 then blockSize else padbyte in + B.replicate padbyte' (fromIntegral (padbyte' - 1)) + else + B.empty + let e = encrypt writekey (cstIV cst) (B.concat [ content, padding ]) + if hasExplicitBlockIV ver + then return $ B.concat [cstIV cst,e] + else do + let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e + put $ tstate { stCryptState = 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 $ tstate { stCryptState = cst { cstIV = newiv } } + return e diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/State.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +-- | +-- Module : Network.TLS.Record.State +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Record.State + ( CryptState(..) + , MacState(..) + , RecordState(..) + , newRecordState + , RecordM + , runRecordM + , getRecordVersion + , setRecordIV + , withCompression + , computeDigest + , makeDigest + ) where + +import Data.Word +import Control.Monad.State +import Control.Monad.Error +import Network.TLS.Compression +import Network.TLS.Cipher +import Network.TLS.Struct +import Network.TLS.Wire + +import Network.TLS.Packet +import Network.TLS.MAC +import Network.TLS.Util + +import qualified Data.ByteString as B + +data CryptState = CryptState + { cstKey :: !Bytes + , cstIV :: !Bytes + , cstMacSecret :: !Bytes + } deriving (Show) + +newtype MacState = MacState + { msSequence :: Word64 + } deriving (Show) + +data RecordState = RecordState + { stCipher :: Maybe Cipher + , stCompression :: Compression + , stCryptState :: !CryptState + , stMacState :: !MacState + } deriving (Show) + +newtype RecordM a = RecordM { runRecordM :: Version + -> RecordState + -> Either TLSError (a, RecordState) } + +instance Monad RecordM where + return a = RecordM $ \_ st -> Right (a, st) + m1 >>= m2 = RecordM $ \ver st -> do + case runRecordM m1 ver st of + Left err -> Left err + Right (a, st2) -> runRecordM (m2 a) ver st2 + +instance Functor RecordM where + fmap f m = RecordM $ \ver st -> + case runRecordM m ver st of + Left err -> Left err + Right (a, st2) -> Right (f a, st2) + +getRecordVersion :: RecordM Version +getRecordVersion = RecordM $ \ver st -> Right (ver, st) + +instance MonadState RecordState RecordM where + put x = RecordM $ \_ _ -> Right ((), x) + get = RecordM $ \_ st -> Right (st, st) +#if MIN_VERSION_mtl(2,1,0) + state f = RecordM $ \_ st -> Right (f st) +#endif + +instance MonadError TLSError RecordM where + throwError e = RecordM $ \_ _ -> Left e + catchError m f = RecordM $ \ver st -> + case runRecordM m ver st of + Left err -> runRecordM (f err) ver st + r -> r + +newRecordState :: RecordState +newRecordState = RecordState + { stCipher = Nothing + , stCompression = nullCompression + , stCryptState = CryptState B.empty B.empty B.empty + , stMacState = MacState 0 + } + +incrRecordState :: RecordState -> RecordState +incrRecordState ts = ts { stMacState = MacState (ms + 1) } + where (MacState ms) = stMacState ts + +setRecordIV :: Bytes -> RecordState -> RecordState +setRecordIV iv st = st { stCryptState = (stCryptState st) { cstIV = iv } } + +withCompression :: (Compression -> (Compression, a)) -> RecordM a +withCompression f = do + st <- get + let (nc, a) = f $ stCompression st + put $ st { stCompression = nc } + return a + +computeDigest :: Version -> RecordState -> Header -> Bytes -> (Bytes, RecordState) +computeDigest ver tstate hdr content = (digest, incrRecordState tstate) + where digest = macF (cstMacSecret cst) msg + cst = stCryptState tstate + cipher = fromJust "cipher" $ stCipher tstate + hashf = hashF $ cipherHash cipher + encodedSeq = encodeWord64 $ msSequence $ stMacState tstate + + (macF, msg) + | ver < TLS10 = (macSSL hashf, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ]) + | otherwise = (hmac hashf 64, B.concat [ encodedSeq, encodeHeader hdr, content ]) + +makeDigest :: Header -> Bytes -> RecordM Bytes +makeDigest hdr content = do + ver <- getRecordVersion + st <- get + let (digest, nstate) = computeDigest ver st hdr content + put nstate + return digest 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,33 +13,33 @@ -- 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 +import Network.TLS.Record.State import qualified Data.ByteString as B import Control.Applicative ((<$>)) @@ -61,26 +61,26 @@ fragmentGetBytes :: Fragment a -> Bytes fragmentGetBytes (Fragment bytes) = bytes -onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b) +onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag -fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b) +fragmentMap :: (Bytes -> RecordM Bytes) -> Fragment a -> RecordM (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b -- | turn a plaintext record into a compressed record using the compression function supplied -fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed) +fragmentCompress :: (Bytes -> RecordM Bytes) -> Fragment Plaintext -> RecordM (Fragment Compressed) fragmentCompress f = fragmentMap f -- | turn a compressed record into a ciphertext record using the cipher function supplied -fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext) +fragmentCipher :: (Bytes -> RecordM Bytes) -> Fragment Compressed -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied -fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed) +fragmentUncipher :: (Bytes -> RecordM Bytes) -> Fragment Ciphertext -> RecordM (Fragment Compressed) fragmentUncipher f = fragmentMap f -- | turn a compressed fragment into a plaintext fragment using the decompression function supplied -fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext) +fragmentUncompress :: (Bytes -> RecordM Bytes) -> Fragment Compressed -> RecordM (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -8,100 +8,83 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state -- -module Network.TLS.Sending (writePacket, encryptRSA, signRSA) where +module Network.TLS.Sending (writePacket) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad.State +import Control.Concurrent.MVar +import Data.IORef import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Network.TLS.Util +import Network.TLS.Types (Role(..)) +import Network.TLS.Cap import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet +import Network.TLS.Context.Internal +import Network.TLS.Parameters import Network.TLS.State -import Network.TLS.Crypto +import Network.TLS.Handshake.State +import Network.TLS.Cipher +import Network.TLS.Util -{- - - 'makePacketData' create a Header and a content bytestring related to a packet - - this doesn't change any state - -} -makeRecord :: Packet -> TLSSt (Record Plaintext) +-- | 'makePacketData' create a Header and a content bytestring related to a packet +-- this doesn't change any state +makeRecord :: Packet -> RecordM (Record Plaintext) makeRecord pkt = do - ver <- stVersion <$> get - content <- writePacketContent pkt - return $ Record (packetType pkt) ver (fragmentPlaintext content) - -{- - - ChangeCipherSpec state change need to be handled after encryption otherwise - - its own packet would be encrypted with the new context, instead of beeing sent - - under the current context - -} -postprocessRecord :: Record Ciphertext -> TLSSt (Record Ciphertext) -postprocessRecord record@(Record ProtocolType_ChangeCipherSpec _ _) = - switchTxEncryption >> return record -postprocessRecord record = return record + ver <- getRecordVersion + return $ Record (packetType pkt) ver (fragmentPlaintext $ writePacketContent pkt) + where writePacketContent (Handshake hss) = encodeHandshakes hss + writePacketContent (Alert a) = encodeAlerts a + writePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec + writePacketContent (AppData x) = x -{- - - marshall packet data - -} -encodeRecord :: Record Ciphertext -> TLSSt ByteString +-- | marshall packet data +encodeRecord :: Record Ciphertext -> RecordM ByteString encodeRecord record = return $ B.concat [ encodeHeader hdr, content ] - where (hdr, content) = recordToRaw record + where (hdr, content) = recordToRaw record -{- - - just update TLS state machine - -} -preProcessPacket :: Packet -> TLSSt () -preProcessPacket (Alert _) = return () -preProcessPacket (AppData _) = return () -preProcessPacket (ChangeCipherSpec) = return () -preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do +-- | writePacket transform a packet into marshalled data related to current state +-- and updating state on the go +writePacket :: Context -> Packet -> IO (Either TLSError ByteString) +writePacket ctx pkt@(Handshake hss) = do + forM_ hss $ \hs -> do case hs of - Finished fdata -> updateVerifiedData True fdata - _ -> return () - when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage $ encodeHandshake hs - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) - -{- - - writePacket transform a packet into marshalled data related to current state - - and updating state on the go - -} -writePacket :: Packet -> TLSSt ByteString -writePacket pkt = do - preProcessPacket pkt - makeRecord pkt >>= engageRecord >>= postprocessRecord >>= encodeRecord - -{------------------------------------------------------------------------------} -{- SENDING Helpers -} -{------------------------------------------------------------------------------} - -{- if the RSA encryption fails we just return an empty bytestring, and let the protocol - - fail by itself; however it would be probably better to just report it since it's an internal problem. - -} -encryptRSA :: ByteString -> TLSSt ByteString -encryptRSA content = do - st <- get - let rsakey = fromJust "rsa public key" $ hstRSAPublicKey $ fromJust "handshake" $ stHandshake st - (v,rng') = withTLSRNG (stRandomGen st) (\g -> kxEncrypt g rsakey content) - in do put (st { stRandomGen = rng' }) - case v of - Left err -> fail ("rsa encrypt failed: " ++ show err) - Right econtent -> return econtent + Finished fdata -> usingState_ ctx $ updateVerifiedData ClientRole fdata + _ -> return () + let encoded = encodeHandshake hs + usingHState ctx $ do + when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded + when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded + prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord) +writePacket ctx pkt = do + d <- prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord) + when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx + return d -signRSA :: HashDescr -> ByteString -> TLSSt ByteString -signRSA hsh content = do - st <- get - let rsakey = fromJust "rsa client private key" $ hstRSAClientPrivateKey $ fromJust "handshake" $ stHandshake st - let (r, rng') = withTLSRNG (stRandomGen st) (\g -> kxSign g rsakey hsh content) - put (st { stRandomGen = rng' }) - case r of - Left err -> fail ("rsa sign failed: " ++ show err) - Right econtent -> return econtent +-- before TLS 1.1, the block cipher IV is made of the residual of the previous block, +-- so we use cstIV as is, however in other case we generate an explicit IV +prepareRecord :: Context -> RecordM a -> IO (Either TLSError a) +prepareRecord ctx f = do + ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) + txState <- readMVar $ ctxTxState ctx + let sz = case stCipher $ txState of + Nothing -> 0 + Just cipher -> bulkIVSize $ cipherBulk cipher + if hasExplicitBlockIV ver && sz > 0 + then do newIV <- getStateRNG ctx sz + runTxState ctx (modify (setRecordIV newIV) >> f) + else runTxState ctx f -writePacketContent :: Packet -> TLSSt ByteString -writePacketContent (Handshake hss) = return $ encodeHandshakes hss -writePacketContent (Alert a) = return $ encodeAlerts a -writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec -writePacketContent (AppData x) = return x +switchTxEncryption :: Context -> IO () +switchTxEncryption ctx = do + tx <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState) + (ver, cc) <- usingState_ ctx $ do v <- getVersion + c <- isClientContext + return (v, c) + liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx) + -- set empty packet counter measure if condition are met + when (ver <= TLS10 && cc == ClientRole && isCBC tx) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True + where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs --- a/Network/TLS/Session.hs +++ b/Network/TLS/Session.hs @@ -5,26 +5,26 @@ -- Stability : experimental -- Portability : unknown -- -{-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Session ( SessionManager(..) - , NoSessionManager(..) + , 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 +data SessionManager = SessionManager + { -- | used on server side to decide whether to resume a client session. + sessionResume :: SessionID -> IO (Maybe SessionData) + -- | used when a session is established. + , sessionEstablish :: SessionID -> SessionData -> IO () + -- | used when a session is invalidated. + , sessionInvalidate :: SessionID -> IO () + } -instance SessionManager NoSessionManager where - sessionResume _ _ = return Nothing - sessionEstablish _ _ _ = return () - sessionInvalidate _ _ = return () +noSessionManager :: SessionManager +noSessionManager = SessionManager + { 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 @@ -1,4 +1,7 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, MultiParamTypeClasses, ExistentialQuantification, RankNTypes, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Network.TLS.State -- License : BSD-style @@ -10,248 +13,100 @@ -- which is use by the Receiving module and the Sending module. -- module Network.TLS.State - ( TLSState(..) - , TLSSt - , runTLSState - , TLSHandshakeState(..) - , TLSCryptState(..) - , TLSMacState(..) - , newTLSState - , genTLSRandom - , withTLSRNG - , withCompression - , assert -- FIXME move somewhere else (Internal.hs ?) - , updateVerifiedData - , finishHandshakeTypeMaterial - , finishHandshakeMaterial - , certVerifyHandshakeTypeMaterial - , certVerifyHandshakeMaterial - , makeDigest - , setMasterSecret - , setMasterSecretFromPre - , getMasterSecret - , setPublicKey - , setPrivateKey - , setClientPublicKey - , setClientPrivateKey - , setClientCertSent - , getClientCertSent - , setCertReqSent - , getCertReqSent - , setClientCertChain - , getClientCertChain - , setClientCertRequest - , getClientCertRequest - , setKeyBlock - , setVersion - , setCipher - , setServerRandom - , setSecureRenegotiation - , getSecureRenegotiation - , setExtensionNPN - , getExtensionNPN - , setNegotiatedProtocol - , getNegotiatedProtocol - , setServerNextProtocolSuggest - , getServerNextProtocolSuggest - , getClientCertificateChain - , setClientCertificateChain - , getVerifiedData - , setSession - , getSession - , getSessionData - , isSessionResuming - , needEmptyPacket - , switchTxEncryption - , switchRxEncryption - , getCipherKeyExchangeType - , isClientContext - , startHandshakeClient - , addHandshakeMessage - , updateHandshakeDigest - , getHandshakeDigest - , getHandshakeMessages - , endHandshake - ) where + ( TLSState(..) + , TLSSt + , runTLSState + , newTLSState + , withTLSRNG + , updateVerifiedData + , finishHandshakeTypeMaterial + , finishHandshakeMaterial + , certVerifyHandshakeTypeMaterial + , certVerifyHandshakeMaterial + , setVersion + , setVersionIfUnset + , getVersion + , getVersionWithDefault + , setSecureRenegotiation + , getSecureRenegotiation + , setExtensionNPN + , getExtensionNPN + , setNegotiatedProtocol + , getNegotiatedProtocol + , setServerNextProtocolSuggest + , getServerNextProtocolSuggest + , getClientCertificateChain + , setClientCertificateChain + , getVerifiedData + , setSession + , getSession + , isSessionResuming + , isClientContext + -- * random + , genRandom + , withRNG + ) where -import Data.Word -import Data.Maybe (isNothing) -import Network.TLS.Util +import Control.Applicative import Network.TLS.Struct -import Network.TLS.Wire -import Network.TLS.Packet -import Network.TLS.Crypto -import Network.TLS.Cipher -import Network.TLS.Compression -import Network.TLS.MAC +import Network.TLS.RNG +import Network.TLS.Types (Role(..)) import qualified Data.ByteString as B -import Control.Applicative ((<$>)) -import Control.Monad import Control.Monad.State import Control.Monad.Error -import Crypto.Random.API -import Data.Certificate.X509 - -assert :: Monad m => String -> [(String,Bool)] -> m () -assert fctname list = forM_ list $ \ (name, assumption) -> do - when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") - -data TLSCryptState = TLSCryptState - { cstKey :: !Bytes - , cstIV :: !Bytes - , cstMacSecret :: !Bytes - } deriving (Show) - -data TLSMacState = TLSMacState - { msSequence :: Word64 - } deriving (Show) - -type ClientCertRequestData = ([CertificateType], - Maybe [(HashAlgorithm, SignatureAlgorithm)], - [DistinguishedName]) - -data TLSHandshakeState = TLSHandshakeState - { hstClientVersion :: !(Version) - , hstClientRandom :: !ClientRandom - , hstServerRandom :: !(Maybe ServerRandom) - , hstMasterSecret :: !(Maybe Bytes) - , hstRSAPublicKey :: !(Maybe PublicKey) - , hstRSAPrivateKey :: !(Maybe PrivateKey) - , hstRSAClientPublicKey :: !(Maybe PublicKey) - , hstRSAClientPrivateKey :: !(Maybe PrivateKey) - , hstHandshakeDigest :: !HashCtx - , hstHandshakeMessages :: [Bytes] - , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received - , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent - , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent - , hstClientCertChain :: !(Maybe [X509]) - } deriving (Show) - -data StateRNG = forall g . CPRG g => StateRNG g - -instance Show StateRNG where - show _ = "rng[..]" +import Crypto.Random +import Data.X509 (CertificateChain) data TLSState = TLSState - { stClientContext :: Bool - , stVersion :: !Version - , stHandshake :: !(Maybe TLSHandshakeState) - , stSession :: Session - , stSessionResuming :: Bool - , stTxEncrypted :: Bool - , stRxEncrypted :: Bool - , stActiveTxCryptState :: !(Maybe TLSCryptState) - , stActiveRxCryptState :: !(Maybe TLSCryptState) - , stPendingTxCryptState :: !(Maybe TLSCryptState) - , stPendingRxCryptState :: !(Maybe TLSCryptState) - , stActiveTxMacState :: !(Maybe TLSMacState) - , stActiveRxMacState :: !(Maybe TLSMacState) - , stPendingTxMacState :: !(Maybe TLSMacState) - , stPendingRxMacState :: !(Maybe TLSMacState) - , stActiveTxCipher :: Maybe Cipher - , stActiveRxCipher :: Maybe Cipher - , stPendingCipher :: Maybe Cipher - , stCompression :: Compression - , stRandomGen :: StateRNG - , stSecureRenegotiation :: Bool -- RFC 5746 - , stClientVerifiedData :: Bytes -- RFC 5746 - , stServerVerifiedData :: Bytes -- RFC 5746 - , stExtensionNPN :: Bool -- NPN draft extension - , stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol - , stServerNextProtocolSuggest :: Maybe [B.ByteString] - , stClientCertificateChain :: Maybe [X509] - } deriving (Show) + { stSession :: Session + , stSessionResuming :: Bool + , 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 CertificateChain + , stRandomGen :: StateRNG + , stVersion :: Maybe Version + , stClientContext :: Role + } deriving (Show) newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a } - deriving (Monad, MonadError TLSError) - -instance Functor TLSSt where - fmap f = TLSSt . fmap f . runTLSSt + deriving (Monad, MonadError TLSError, Functor, Applicative) 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) runTLSState f st = runState (runErrorT (runTLSSt f)) st -newTLSState :: CPRG g => g -> TLSState -newTLSState rng = TLSState - { stClientContext = False - , stVersion = TLS10 - , stHandshake = Nothing - , stSession = Session Nothing - , stSessionResuming = False - , stTxEncrypted = False - , stRxEncrypted = False - , stActiveTxCryptState = Nothing - , stActiveRxCryptState = Nothing - , stPendingTxCryptState = Nothing - , stPendingRxCryptState = Nothing - , stActiveTxMacState = Nothing - , stActiveRxMacState = Nothing - , stPendingTxMacState = Nothing - , stPendingRxMacState = Nothing - , stActiveTxCipher = Nothing - , stActiveRxCipher = Nothing - , stPendingCipher = Nothing - , stCompression = nullCompression - , stRandomGen = StateRNG rng - , stSecureRenegotiation = False - , stClientVerifiedData = B.empty - , stServerVerifiedData = B.empty - , stExtensionNPN = False - , stNegotiatedProtocol = Nothing - , stServerNextProtocolSuggest = Nothing - , stClientCertificateChain = Nothing - } - -withTLSRNG :: StateRNG -> (forall g . CPRG g => g -> (a,g)) -> (a, StateRNG) -withTLSRNG (StateRNG rng) f = let (a, rng') = f rng - in (a, StateRNG rng') - -withCompression :: (Compression -> (Compression, a)) -> TLSSt a -withCompression f = do - compression <- stCompression <$> get - let (nc, a) = f compression - modify (\st -> st { stCompression = nc }) - return a - -genTLSRandom :: (MonadState TLSState m, MonadError TLSError m) => Int -> m Bytes -genTLSRandom n = do - st <- get - case withTLSRNG (stRandomGen st) (cprgGenerate n) of - (bytes, rng') -> put (st { stRandomGen = rng' }) >> return bytes - -makeDigest :: MonadState TLSState m => Bool -> Header -> Bytes -> m Bytes -makeDigest w hdr content = do - st <- get - let ver = stVersion st - let cst = fromJust "crypt state" $ if w then stActiveTxCryptState st else stActiveRxCryptState st - let ms = fromJust "mac state" $ if w then stActiveTxMacState st else stActiveRxMacState st - let cipher = fromJust "cipher" $ if w then stActiveTxCipher st else stActiveRxCipher st - let hashf = hashF $ cipherHash cipher - - let (macF, msg) = - if ver < TLS10 - then (macSSL hashf, B.concat [ encodeWord64 $ msSequence ms, encodeHeaderNoVer hdr, content ]) - else (hmac hashf 64, B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ]) - let digest = macF (cstMacSecret cst) msg - - let newms = ms { msSequence = (msSequence ms) + 1 } - - modify (\_ -> if w then st { stActiveTxMacState = Just newms } else st { stActiveRxMacState = Just newms }) - return digest +newTLSState :: CPRG g => g -> Role -> TLSState +newTLSState rng clientContext = TLSState + { stSession = Session Nothing + , stSessionResuming = False + , stSecureRenegotiation = False + , stClientVerifiedData = B.empty + , stServerVerifiedData = B.empty + , stExtensionNPN = False + , stNegotiatedProtocol = Nothing + , stServerNextProtocolSuggest = Nothing + , stClientCertificateChain = Nothing + , stRandomGen = StateRNG rng + , stVersion = Nothing + , stClientContext = clientContext + } -updateVerifiedData :: MonadState TLSState m => Bool -> Bytes -> m () +updateVerifiedData :: Role -> Bytes -> TLSSt () updateVerifiedData sending bs = do - cc <- isClientContext - if cc /= sending - then modify (\st -> st { stServerVerifiedData = bs }) - else modify (\st -> st { stClientVerifiedData = bs }) + cc <- isClientContext + if cc /= sending + then modify (\st -> st { stServerVerifiedData = bs }) + else modify (\st -> st { stClientVerifiedData = bs }) finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello = True @@ -285,236 +140,75 @@ certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake -switchTxEncryption, switchRxEncryption :: MonadState TLSState m => m () -switchTxEncryption = modify (\st -> st { stTxEncrypted = True - , stActiveTxMacState = stPendingTxMacState st - , stActiveTxCryptState = stPendingTxCryptState st - , stActiveTxCipher = stPendingCipher st }) -switchRxEncryption = modify (\st -> st { stRxEncrypted = True - , stActiveRxMacState = stPendingRxMacState st - , stActiveRxCryptState = stPendingRxCryptState st - , stActiveRxCipher = stPendingCipher st }) - -setServerRandom :: MonadState TLSState m => ServerRandom -> m () -setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran }) - -setMasterSecret :: MonadState TLSState m => Bytes -> m () -setMasterSecret masterSecret = do - hasValidHandshake "master secret" - - updateHandshake "master secret" (\hst -> hst { hstMasterSecret = Just masterSecret } ) - setKeyBlock - return () - -setMasterSecretFromPre :: MonadState TLSState m => Bytes -> m () -setMasterSecretFromPre premasterSecret = do - hasValidHandshake "generate master secret" - st <- get - setMasterSecret $ genSecret st - where - genSecret st = - let hst = fromJust "handshake" $ stHandshake st in - generateMasterSecret (stVersion st) - premasterSecret - (hstClientRandom hst) - (fromJust "server random" $ hstServerRandom hst) - -getMasterSecret :: MonadState TLSState m => m (Maybe Bytes) -getMasterSecret = gets (stHandshake >=> hstMasterSecret) - -setPublicKey :: MonadState TLSState m => PublicKey -> m () -setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk }) - -setPrivateKey :: MonadState TLSState m => PrivateKey -> m () -setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk }) - -setClientPublicKey :: MonadState TLSState m => PublicKey -> m () -setClientPublicKey pk = updateHandshake "client publickey" (\hst -> hst { hstRSAClientPublicKey = Just pk }) - -setClientPrivateKey :: MonadState TLSState m => PrivateKey -> m () -setClientPrivateKey pk = updateHandshake "client privatekey" (\hst -> hst { hstRSAClientPrivateKey = Just pk }) - -setCertReqSent :: MonadState TLSState m => Bool -> m () -setCertReqSent b = updateHandshake "client cert req sent" (\hst -> hst { hstCertReqSent = b }) - -getCertReqSent :: MonadState TLSState m => m (Maybe Bool) -getCertReqSent = gets (stHandshake >=> Just . hstCertReqSent) - -setClientCertSent :: MonadState TLSState m => Bool -> m () -setClientCertSent b = updateHandshake "client cert sent" (\hst -> hst { hstClientCertSent = b }) - -getClientCertSent :: MonadState TLSState m => m (Maybe Bool) -getClientCertSent = gets (stHandshake >=> Just . hstClientCertSent) - -setClientCertChain :: MonadState TLSState m => [X509] -> m () -setClientCertChain b = updateHandshake "client certificate chain" (\hst -> hst { hstClientCertChain = Just b }) - -getClientCertChain :: MonadState TLSState m => m (Maybe [X509]) -getClientCertChain = gets (stHandshake >=> hstClientCertChain) - -setClientCertRequest :: MonadState TLSState m => ClientCertRequestData -> m () -setClientCertRequest d = updateHandshake "client cert data" (\hst -> hst { hstClientCertRequest = Just d }) - -getClientCertRequest :: MonadState TLSState m => m (Maybe ClientCertRequestData) -getClientCertRequest = gets (stHandshake >=> hstClientCertRequest) - -getSessionData :: MonadState TLSState m => m (Maybe SessionData) -getSessionData = get >>= \st -> return (stHandshake st >>= hstMasterSecret >>= wrapSessionData st) - where wrapSessionData st masterSecret = do - return $ SessionData - { sessionVersion = stVersion st - , sessionCipher = cipherID $ fromJust "cipher" $ stActiveTxCipher st - , sessionSecret = masterSecret - } - -setSession :: MonadState TLSState m => Session -> Bool -> m () +setSession :: Session -> Bool -> TLSSt () setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming }) -getSession :: MonadState TLSState m => m Session +getSession :: TLSSt Session getSession = gets stSession -isSessionResuming :: MonadState TLSState m => m Bool +isSessionResuming :: TLSSt Bool isSessionResuming = gets stSessionResuming -needEmptyPacket :: MonadState TLSState m => m Bool -needEmptyPacket = gets f - where f st = (stVersion st <= TLS10) - && stClientContext st - && (maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stActiveTxCipher st)) - -setKeyBlock :: MonadState TLSState m => m () -setKeyBlock = modify setPendingState where - setPendingState st = st { stPendingTxCryptState = Just $ if cc then cstClient else cstServer - , stPendingRxCryptState = Just $ if cc then cstServer else cstClient - , stPendingTxMacState = Just $ if cc then msClient else msServer - , stPendingRxMacState = Just $ if cc then msServer else msClient - } - where hst = fromJust "handshake" $ stHandshake st - cc = stClientContext st - cipher = fromJust "cipher" $ stPendingCipher st - keyblockSize = cipherKeyBlockSize cipher - - bulk = cipherBulk cipher - digestSize = hashSize $ cipherHash cipher - keySize = bulkKeySize bulk - ivSize = bulkIVSize bulk - kb = generateKeyBlock (stVersion st) (hstClientRandom hst) - (fromJust "server random" $ hstServerRandom hst) - (fromJust "master secret" $ hstMasterSecret hst) keyblockSize - - (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = - fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) +setVersion :: Version -> TLSSt () +setVersion ver = modify (\st -> st { stVersion = Just ver }) - cstClient = TLSCryptState { cstKey = cWriteKey - , cstIV = cWriteIV - , cstMacSecret = cMACSecret } - cstServer = TLSCryptState { cstKey = sWriteKey - , cstIV = sWriteIV - , cstMacSecret = sMACSecret } - msClient = TLSMacState { msSequence = 0 } - msServer = TLSMacState { msSequence = 0 } +setVersionIfUnset :: Version -> TLSSt () +setVersionIfUnset ver = modify maybeSet + where maybeSet st = case stVersion st of + Nothing -> st { stVersion = Just ver } + Just _ -> st -setCipher :: MonadState TLSState m => Cipher -> m () -setCipher cipher = modify (\st -> st { stPendingCipher = Just cipher }) +getVersion :: TLSSt Version +getVersion = maybe (error $ "internal error: version hasn't been set yet") id <$> gets stVersion -setVersion :: MonadState TLSState m => Version -> m () -setVersion ver = modify (\st -> st { stVersion = ver }) +getVersionWithDefault :: Version -> TLSSt Version +getVersionWithDefault defaultVer = maybe defaultVer id <$> gets stVersion -setSecureRenegotiation :: MonadState TLSState m => Bool -> m () +setSecureRenegotiation :: Bool -> TLSSt () setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b }) -getSecureRenegotiation :: MonadState TLSState m => m Bool +getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation -setExtensionNPN :: MonadState TLSState m => Bool -> m () +setExtensionNPN :: Bool -> TLSSt () setExtensionNPN b = modify (\st -> st { stExtensionNPN = b }) -getExtensionNPN :: MonadState TLSState m => m Bool +getExtensionNPN :: TLSSt Bool getExtensionNPN = gets stExtensionNPN -setNegotiatedProtocol :: MonadState TLSState m => B.ByteString -> m () +setNegotiatedProtocol :: B.ByteString -> TLSSt () setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s }) -getNegotiatedProtocol :: MonadState TLSState m => m (Maybe B.ByteString) +getNegotiatedProtocol :: TLSSt (Maybe B.ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol -setServerNextProtocolSuggest :: MonadState TLSState m => [B.ByteString] -> m () +setServerNextProtocolSuggest :: [B.ByteString] -> TLSSt () setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps}) -getServerNextProtocolSuggest :: MonadState TLSState m => m (Maybe [B.ByteString]) -getServerNextProtocolSuggest = get >>= return . stServerNextProtocolSuggest +getServerNextProtocolSuggest :: TLSSt (Maybe [B.ByteString]) +getServerNextProtocolSuggest = gets stServerNextProtocolSuggest -setClientCertificateChain :: MonadState TLSState m => [X509] -> m () +setClientCertificateChain :: CertificateChain -> TLSSt () setClientCertificateChain s = modify (\st -> st { stClientCertificateChain = Just s }) -getClientCertificateChain :: MonadState TLSState m => m (Maybe [X509]) +getClientCertificateChain :: TLSSt (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain -getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType) -getCipherKeyExchangeType = gets (\st -> cipherKeyExchange <$> stPendingCipher st) - -getVerifiedData :: MonadState TLSState m => Bool -> m Bytes -getVerifiedData client = gets (if client then stClientVerifiedData else stServerVerifiedData) +getVerifiedData :: Role -> TLSSt Bytes +getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) -isClientContext :: MonadState TLSState m => m Bool +isClientContext :: TLSSt Role isClientContext = gets stClientContext --- create a new empty handshake state -newEmptyHandshake :: Version -> ClientRandom -> HashCtx -> TLSHandshakeState -newEmptyHandshake ver crand digestInit = TLSHandshakeState - { hstClientVersion = ver - , hstClientRandom = crand - , hstServerRandom = Nothing - , hstMasterSecret = Nothing - , hstRSAPublicKey = Nothing - , hstRSAPrivateKey = Nothing - , hstRSAClientPublicKey = Nothing - , hstRSAClientPrivateKey = Nothing - , hstHandshakeDigest = digestInit - , hstHandshakeMessages = [] - , hstClientCertRequest = Nothing - , hstClientCertSent = False - , hstCertReqSent = False - , hstClientCertChain = Nothing - } - -startHandshakeClient :: MonadState TLSState m => Version -> ClientRandom -> m () -startHandshakeClient ver crand = do - -- FIXME check if handshake is already not null - let initCtx = if ver < TLS12 then hashMD5SHA1 else hashSHA256 - chs <- get >>= return . stHandshake - when (isNothing chs) $ - modify (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand initCtx }) - -hasValidHandshake :: MonadState TLSState m => String -> m () -hasValidHandshake name = get >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ] - -updateHandshake :: MonadState TLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m () -updateHandshake n f = do - hasValidHandshake n - modify (\st -> st { stHandshake = f <$> stHandshake st }) - -addHandshakeMessage :: MonadState TLSState m => Bytes -> m () -addHandshakeMessage content = updateHandshake "add handshake message" $ \hs -> - hs { hstHandshakeMessages = content : hstHandshakeMessages hs} - -getHandshakeMessages :: MonadState TLSState m => m [Bytes] -getHandshakeMessages = do - st <- get - let hst = fromJust "handshake" $ stHandshake st - return $ reverse $ hstHandshakeMessages hst - -updateHandshakeDigest :: MonadState TLSState m => Bytes -> m () -updateHandshakeDigest content = updateHandshake "update digest" $ \hs -> - hs { hstHandshakeDigest = hashUpdate (hstHandshakeDigest hs) content } - -getHandshakeDigest :: MonadState TLSState m => Bool -> m Bytes -getHandshakeDigest client = do - st <- get - let hst = fromJust "handshake" $ stHandshake st - let hashctx = hstHandshakeDigest hst - let msecret = fromJust "master secret" $ hstMasterSecret hst - return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret hashctx +genRandom :: Int -> TLSSt Bytes +genRandom n = do + st <- get + case withTLSRNG (stRandomGen st) (cprgGenerate n) of + (bytes, rng') -> put (st { stRandomGen = rng' }) >> return bytes -endHandshake :: MonadState TLSState m => m () -endHandshake = modify (\st -> st { stHandshake = Nothing }) +withRNG :: (forall g . CPRG g => g -> (a, g)) -> TLSSt a +withRNG f = do + st <- get + let (a,rng') = withTLSRNG (stRandomGen st) f + put (st { stRandomGen = rng' }) + return a diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -10,131 +10,149 @@ -- the Struct module contains all definitions and values of the TLS protocol -- module Network.TLS.Struct - ( Bytes - , Version(..) - , ConnectionEnd(..) - , CipherType(..) - , CipherData(..) - , ExtensionID - , ExtensionRaw - , CertificateType(..) - , HashAlgorithm(..) - , SignatureAlgorithm(..) - , HashAndSignatureAlgorithm - , ProtocolType(..) - , TLSError(..) - , DistinguishedName - , ServerDHParams(..) - , ServerRSAParams(..) - , ServerKeyXchgAlgorithmData(..) - , Packet(..) - , Header(..) - , ServerRandom(..) - , ClientRandom(..) - , serverRandom - , clientRandom - , FinishedData - , SessionID - , Session(..) - , SessionData(..) - , CertVerifyData(..) - , AlertLevel(..) - , AlertDescription(..) - , HandshakeType(..) - , Handshake(..) - , numericalVer - , verOfNum - , TypeValuable, valOfType, valToType - , packetType - , typeOfHandshake - ) where + ( Bytes + , Version(..) + , ConnectionEnd(..) + , CipherType(..) + , CipherData(..) + , ExtensionID + , ExtensionRaw + , CertificateType(..) + , HashAlgorithm(..) + , SignatureAlgorithm(..) + , HashAndSignatureAlgorithm + , DigitallySigned(..) + , ProtocolType(..) + , TLSError(..) + , TLSException(..) + , DistinguishedName + , ServerDHParams(..) + , ServerRSAParams(..) + , ServerKeyXchgAlgorithmData(..) + , ClientKeyXchgAlgorithmData(..) + , Packet(..) + , Header(..) + , ServerRandom(..) + , ClientRandom(..) + , serverRandom + , clientRandom + , FinishedData + , SessionID + , Session(..) + , SessionData(..) + , 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.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Monad.Error (Error(..)) import Control.Exception (Exception(..)) import Network.TLS.Types +import Network.TLS.Crypto.DH type Bytes = ByteString - data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD data CipherData = CipherData - { cipherDataContent :: Bytes - , cipherDataMAC :: Maybe Bytes - , cipherDataPadding :: Maybe Bytes - } deriving (Show,Eq) + { 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) +type Signature = Bytes + +data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature + deriving (Show,Eq) + data ProtocolType = - ProtocolType_ChangeCipherSpec - | ProtocolType_Alert - | ProtocolType_Handshake - | ProtocolType_AppData - | ProtocolType_DeprecatedHandshake - deriving (Eq, Show) + ProtocolType_ChangeCipherSpec + | ProtocolType_Alert + | ProtocolType_Handshake + | ProtocolType_AppData + | ProtocolType_DeprecatedHandshake + deriving (Eq, Show) -- | TLSError that might be returned through the TLS stack data TLSError = - Error_Misc String -- ^ mainly for instance of Error - | Error_Protocol (String, Bool, AlertDescription) - | Error_Certificate String - | Error_HandshakePolicy String -- ^ handshake policy failed. - | Error_EOF - | Error_Packet String - | Error_Packet_unexpected String String - | Error_Packet_Parsing String - deriving (Eq, Show, Typeable) + Error_Misc String -- ^ mainly for instance of Error + | Error_Protocol (String, Bool, AlertDescription) + | Error_Certificate String + | Error_HandshakePolicy String -- ^ handshake policy failed. + | Error_EOF + | Error_Packet String + | Error_Packet_unexpected String String + | Error_Packet_Parsing String + deriving (Eq, Show, Typeable) instance Error TLSError where - noMsg = Error_Misc "" - strMsg = Error_Misc + noMsg = Error_Misc "" + strMsg = Error_Misc instance Exception TLSError +-- | TLS Exceptions related to bad user usage or +-- asynchronous errors +data TLSException = + Terminated Bool String TLSError -- ^ Early termination exception with the reason + -- and the error associated + | HandshakeFailed TLSError -- ^ Handshake failed for the reason attached + | ConnectionNotEstablished -- ^ Usage error when the connection has not been established + -- and the user is trying to send or receive data + deriving (Show,Eq,Typeable) + +instance Exception TLSException + data Packet = - Handshake [Handshake] - | Alert [(AlertLevel, AlertDescription)] - | ChangeCipherSpec - | AppData ByteString - deriving (Show,Eq) + Handshake [Handshake] + | Alert [(AlertLevel, AlertDescription)] + | ChangeCipherSpec + | AppData ByteString + deriving (Show,Eq) data Header = Header ProtocolType Version Word16 deriving (Show,Eq) @@ -146,9 +164,6 @@ 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 @@ -159,91 +174,93 @@ 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 - | UnsupportedExtension - | CertificateUnobtainable - | UnrecognizedName - | BadCertificateStatusResponse - | BadCertificateHashValue - 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 - | HandshakeType_NPN -- Next Protocol Negotiation extension - 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) +data ServerDHParams = ServerDHParams DHParams {- (p,g) -} DHPublic {- y -} + 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 DigitallySigned + | SKX_DHE_RSA ServerDHParams DigitallySigned + | SKX_RSA (Maybe ServerRSAParams) + | SKX_DH_DSS (Maybe ServerRSAParams) + | SKX_DH_RSA (Maybe ServerRSAParams) + | SKX_Unknown Bytes + deriving (Show,Eq) +data ClientKeyXchgAlgorithmData = + CKX_RSA Bytes + | CKX_DH DHPublic + deriving (Show,Eq) + type DeprecatedRecord = ByteString data Handshake = - ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) - | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] - | Certificates [X509] - | HelloRequest - | ServerHelloDone - | ClientKeyXchg Bytes - | ServerKeyXchg ServerKeyXchgAlgorithmData - | CertRequest [CertificateType] (Maybe [ HashAndSignatureAlgorithm ]) [DistinguishedName] - | CertVerify (Maybe HashAndSignatureAlgorithm) CertVerifyData - | Finished FinishedData - | HsNextProtocolNegotiation Bytes -- NPN extension - deriving (Show,Eq) + ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) + | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] + | Certificates CertificateChain + | HelloRequest + | ServerHelloDone + | ClientKeyXchg ClientKeyXchgAlgorithmData + | ServerKeyXchg ServerKeyXchgAlgorithmData + | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName] + | CertVerify DigitallySigned + | Finished FinishedData + | HsNextProtocolNegotiation Bytes -- NPN extension + deriving (Show,Eq) packetType :: Packet -> ProtocolType packetType (Handshake _) = ProtocolType_Handshake @@ -280,181 +297,181 @@ 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_DeprecatedHandshake = 128 -- unused + valOfType ProtocolType_ChangeCipherSpec = 20 + valOfType ProtocolType_Alert = 21 + valOfType ProtocolType_Handshake = 22 + valOfType ProtocolType_AppData = 23 + valOfType ProtocolType_DeprecatedHandshake = 128 -- unused - valToType 20 = Just ProtocolType_ChangeCipherSpec - valToType 21 = Just ProtocolType_Alert - valToType 22 = Just ProtocolType_Handshake - valToType 23 = Just ProtocolType_AppData - valToType _ = Nothing + valToType 20 = Just ProtocolType_ChangeCipherSpec + valToType 21 = Just ProtocolType_Alert + valToType 22 = Just ProtocolType_Handshake + valToType 23 = Just ProtocolType_AppData + valToType _ = Nothing instance TypeValuable HandshakeType where - valOfType HandshakeType_HelloRequest = 0 - valOfType HandshakeType_ClientHello = 1 - valOfType HandshakeType_ServerHello = 2 - valOfType HandshakeType_Certificate = 11 - valOfType HandshakeType_ServerKeyXchg = 12 - valOfType HandshakeType_CertRequest = 13 - valOfType HandshakeType_ServerHelloDone = 14 - valOfType HandshakeType_CertVerify = 15 - valOfType HandshakeType_ClientKeyXchg = 16 - valOfType HandshakeType_Finished = 20 - valOfType HandshakeType_NPN = 67 + valOfType HandshakeType_HelloRequest = 0 + valOfType HandshakeType_ClientHello = 1 + valOfType HandshakeType_ServerHello = 2 + valOfType HandshakeType_Certificate = 11 + valOfType HandshakeType_ServerKeyXchg = 12 + valOfType HandshakeType_CertRequest = 13 + valOfType HandshakeType_ServerHelloDone = 14 + valOfType HandshakeType_CertVerify = 15 + valOfType HandshakeType_ClientKeyXchg = 16 + valOfType HandshakeType_Finished = 20 + valOfType HandshakeType_NPN = 67 - valToType 0 = Just HandshakeType_HelloRequest - valToType 1 = Just HandshakeType_ClientHello - valToType 2 = Just HandshakeType_ServerHello - valToType 11 = Just HandshakeType_Certificate - valToType 12 = Just HandshakeType_ServerKeyXchg - valToType 13 = Just HandshakeType_CertRequest - valToType 14 = Just HandshakeType_ServerHelloDone - valToType 15 = Just HandshakeType_CertVerify - valToType 16 = Just HandshakeType_ClientKeyXchg - valToType 20 = Just HandshakeType_Finished - valToType 67 = Just HandshakeType_NPN - valToType _ = Nothing + 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 UnsupportedExtension = 110 - valOfType CertificateUnobtainable = 111 - valOfType UnrecognizedName = 112 - valOfType BadCertificateStatusResponse = 113 - valOfType BadCertificateHashValue = 114 + valOfType CloseNotify = 0 + valOfType UnexpectedMessage = 10 + valOfType BadRecordMac = 20 + valOfType DecryptionFailed = 21 + valOfType RecordOverflow = 22 + valOfType DecompressionFailure = 30 + valOfType HandshakeFailure = 40 + valOfType BadCertificate = 42 + valOfType UnsupportedCertificate = 43 + valOfType CertificateRevoked = 44 + valOfType CertificateExpired = 45 + valOfType CertificateUnknown = 46 + valOfType IllegalParameter = 47 + valOfType UnknownCa = 48 + valOfType AccessDenied = 49 + valOfType DecodeError = 50 + valOfType DecryptError = 51 + valOfType ExportRestriction = 60 + valOfType ProtocolVersion = 70 + valOfType InsufficientSecurity = 71 + valOfType InternalError = 80 + valOfType UserCanceled = 90 + valOfType NoRenegotiation = 100 + valOfType UnsupportedExtension = 110 + valOfType CertificateUnobtainable = 111 + valOfType UnrecognizedName = 112 + valOfType BadCertificateStatusResponse = 113 + valOfType BadCertificateHashValue = 114 - valToType 0 = Just CloseNotify - valToType 10 = Just UnexpectedMessage - valToType 20 = Just BadRecordMac - valToType 21 = Just DecryptionFailed - valToType 22 = Just RecordOverflow - valToType 30 = Just DecompressionFailure - valToType 40 = Just HandshakeFailure - valToType 42 = Just BadCertificate - valToType 43 = Just UnsupportedCertificate - valToType 44 = Just CertificateRevoked - valToType 45 = Just CertificateExpired - valToType 46 = Just CertificateUnknown - valToType 47 = Just IllegalParameter - valToType 48 = Just UnknownCa - valToType 49 = Just AccessDenied - valToType 50 = Just DecodeError - valToType 51 = Just DecryptError - valToType 60 = Just ExportRestriction - valToType 70 = Just ProtocolVersion - valToType 71 = Just InsufficientSecurity - valToType 80 = Just InternalError - valToType 90 = Just UserCanceled - valToType 100 = Just NoRenegotiation - valToType 110 = Just UnsupportedExtension - valToType 111 = Just CertificateUnobtainable - valToType 112 = Just UnrecognizedName - valToType 113 = Just BadCertificateStatusResponse - valToType 114 = Just BadCertificateHashValue - valToType _ = Nothing + 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 --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -11,6 +11,9 @@ , SessionData(..) , CipherID , CompressionID + , Role(..) + , invertRole + , Direction(..) ) where import Data.ByteString (ByteString) @@ -26,13 +29,25 @@ -- | Session data to resume data SessionData = SessionData - { sessionVersion :: Version - , sessionCipher :: CipherID - , sessionSecret :: ByteString - } + { sessionVersion :: Version + , sessionCipher :: CipherID + , sessionSecret :: ByteString + } deriving (Show,Eq) -- | Cipher identification type CipherID = Word16 -- | Compression identification type CompressionID = Word8 + +-- | Role +data Role = ClientRole | ServerRole + deriving (Show,Eq) + +-- | Direction +data Direction = Tx | Rx + deriving (Show,Eq) + +invertRole :: Role -> Role +invertRole ClientRole = ServerRole +invertRole ServerRole = ClientRole diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Util ( sub , takelast @@ -7,43 +8,46 @@ , and' , (&&!) , bytesEq + , fmapEither + , catchException ) where import Data.List (foldl') import Network.TLS.Struct (Bytes) import qualified Data.ByteString as B +import Control.Exception (fromException) +import qualified Control.Exception as E + 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) | 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 + 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 @@ -67,3 +71,15 @@ bytesEq b1 b2 | B.length b1 /= B.length b2 = False | otherwise = and' $ B.zipWith (==) b1 b2 + +fmapEither :: (a -> b) -> Either l a -> Either l b +fmapEither f e = case e of + Left l -> Left l + Right r -> Right (f r) + +catchException :: IO a -> (E.SomeException -> IO a) -> IO a +catchException f handler = E.catchJust filterExn f handler + where filterExn :: E.SomeException -> Maybe E.SomeException + filterExn e = case fromException e of + Just (_ :: E.AsyncException) -> Nothing + Nothing -> Just e diff --git a/Network/TLS/Util/ASN1.hs b/Network/TLS/Util/ASN1.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Util/ASN1.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Network.TLS.Util.ASN1 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- ASN1 utils for TLS +-- +module Network.TLS.Util.ASN1 + ( decodeASN1Object + , encodeASN1Object + ) where + +import Data.ASN1.Types (fromASN1, toASN1, ASN1Object) +import Data.ASN1.Encoding (decodeASN1', encodeASN1') +import Data.ASN1.BinaryEncoding (DER(..)) +import Data.ByteString (ByteString) + +-- | Attempt to decode a bytestring representing +-- an DER ASN.1 serialized object into the object. +decodeASN1Object :: ASN1Object a + => String + -> ByteString + -> Either String a +decodeASN1Object name bs = + case decodeASN1' DER bs of + Left e -> Left (name ++ ": cannot decode ASN1: " ++ show e) + Right asn1 -> case fromASN1 asn1 of + Left e -> Left (name ++ ": cannot parse ASN1: " ++ show e) + Right (d,_) -> Right d + +-- | Encode an ASN.1 Object to the DER serialized bytestring +encodeASN1Object :: ASN1Object a + => a + -> ByteString +encodeASN1Object obj = encodeASN1' DER $ toASN1 obj [] diff --git a/Network/TLS/Util/Serialization.hs b/Network/TLS/Util/Serialization.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Util/Serialization.hs @@ -0,0 +1,6 @@ +module Network.TLS.Util.Serialization + ( os2ip + , i2osp + ) where + +import Crypto.Number.Serialize (os2ip, i2osp) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -9,37 +9,39 @@ -- all multibytes values are written as big endian. -- module Network.TLS.Wire - ( Get - , runGet - , runGetErr - , runGetMaybe - , remaining - , getWord8 - , getWords8 - , getWord16 - , getWords16 - , getWord24 - , getBytes - , getOpaque8 - , getOpaque16 - , getOpaque24 - , getList - , processBytes - , isEmpty - , Put - , runPut - , putWord8 - , putWords8 - , putWord16 - , putWords16 - , putWord24 - , putBytes - , putOpaque8 - , putOpaque16 - , putOpaque24 - , encodeWord16 - , encodeWord64 - ) where + ( Get + , runGet + , runGetErr + , runGetMaybe + , remaining + , getWord8 + , getWords8 + , getWord16 + , getWords16 + , getWord24 + , getBytes + , getOpaque8 + , getOpaque16 + , getOpaque24 + , getInteger16 + , getList + , processBytes + , isEmpty + , Put + , runPut + , putWord8 + , putWords8 + , putWord16 + , putWords16 + , putWord24 + , putBytes + , putOpaque8 + , putOpaque16 + , putOpaque24 + , putInteger16 + , encodeWord16 + , encodeWord64 + ) where import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G @@ -50,6 +52,7 @@ import Data.Word import Data.Bits import Network.TLS.Struct +import Network.TLS.Util.Serialization runGet :: String -> Get a -> Bytes -> Either String a runGet lbl f = G.runGet (label lbl f) @@ -71,10 +74,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 @@ -85,9 +88,12 @@ getOpaque24 :: Get Bytes getOpaque24 = getWord24 >>= getBytes +getInteger16 :: Get Integer +getInteger16 = os2ip <$> getOpaque16 + getList :: Int -> (Get (Int, a)) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen) - where getElements len + 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)) @@ -97,23 +103,23 @@ 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 @@ -126,6 +132,9 @@ putOpaque24 :: Bytes -> Put putOpaque24 b = putWord24 (B.length b) >> putBytes b + +putInteger16 :: Integer -> Put +putInteger16 = putOpaque16 . i2osp encodeWord16 :: Word16 -> Bytes encodeWord16 = runPut . putWord16 diff --git a/Network/TLS/X509.hs b/Network/TLS/X509.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/X509.hs @@ -0,0 +1,59 @@ +-- | +-- Module : Network.TLS.X509 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- X509 helpers +-- +module Network.TLS.X509 + ( CertificateChain(..) + , Certificate(..) + , SignedCertificate + , getCertificate + , isNullCertificateChain + , getCertificateChainLeaf + , CertificateRejectReason(..) + , CertificateUsage(..) + , CertificateStore + , ValidationCache + , exceptionValidationCache + , validateDefault + , FailedReason + , ServiceID + , wrapCertificateChecks + ) where + +import Data.X509 +import Data.X509.Validation +import Data.X509.CertificateStore + +isNullCertificateChain :: CertificateChain -> Bool +isNullCertificateChain (CertificateChain l) = null l + +getCertificateChainLeaf :: CertificateChain -> SignedExact Certificate +getCertificateChainLeaf (CertificateChain []) = error "empty certificate chain" +getCertificateChainLeaf (CertificateChain (x:_)) = x + +-- | Certificate and Chain rejection reason +data CertificateRejectReason = + CertificateRejectExpired + | CertificateRejectRevoked + | CertificateRejectUnknownCA + | CertificateRejectOther String + deriving (Show,Eq) + +-- | Certificate Usage callback possible returns values. +data CertificateUsage = + CertificateUsageAccept -- ^ usage of certificate accepted + | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected + deriving (Show,Eq) + +wrapCertificateChecks :: [FailedReason] -> CertificateUsage +wrapCertificateChecks [] = CertificateUsageAccept +wrapCertificateChecks l + | Expired `elem` l = CertificateUsageReject $ CertificateRejectExpired + | InFuture `elem` l = CertificateUsageReject $ CertificateRejectExpired + | UnknownCA `elem` l = CertificateUsageReject $ CertificateRejectUnknownCA + | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs --- a/Tests/Certificate.hs +++ b/Tests/Certificate.hs @@ -1,57 +1,86 @@ +{-# LANGUAGE BangPatterns #-} module Certificate - ( arbitraryX509 - , arbitraryX509WithPublicKey - ) where + ( arbitraryX509 + , arbitraryX509WithKey + , simpleCertificate + , simpleX509 + ) where import Test.QuickCheck -import qualified Data.Certificate.X509 as X509 -import qualified Data.Certificate.X509.Cert as Cert +import Data.X509 import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (secondsToDiffTime) +import Data.Time.Clock (secondsToDiffTime, UTCTime(..)) +import qualified Data.ByteString as B import PubKey -arbitraryDN = return $ Cert.DistinguishedName [] +testExtensionEncode critical ext = ExtensionRaw (extOID ext) critical (extEncode ext) +arbitraryDN = return $ 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) + 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 $ UTCTime (fromGregorian year month day) (secondsToDiffTime (hour * 3600 + minute * 60 + second)) 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 - } +arbitraryCertificate pubKey = do + serial <- choose (0,maxSerial) + issuerdn <- arbitraryDN + subjectdn <- arbitraryDN + time1 <- arbitraryTime + time2 <- arbitraryTime + let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) + return $ Certificate + { certVersion = 3 + , certSerial = serial + , certSignatureAlg = sigalg + , certIssuerDN = issuerdn + , certSubjectDN = subjectdn + , certValidity = (time1, time2) + , certPubKey = pubKey + , certExtensions = Extensions $ Just + [ testExtensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment,KeyUsage_keyCertSign] + ] + } -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) +simpleCertificate pubKey = + Certificate + { certVersion = 3 + , certSerial = 0 + , certSignatureAlg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) + , certIssuerDN = simpleDN + , certSubjectDN = simpleDN + , certValidity = (time1, time2) + , certPubKey = pubKey + , certExtensions = Extensions $ Just + [ testExtensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment] + ] + } + where time1 = UTCTime (fromGregorian 1999 1 1) 0 + time2 = UTCTime (fromGregorian 2901 1 1) 0 + simpleDN = DistinguishedName [] +simpleX509 pubKey = do + let cert = simpleCertificate pubKey + sig = replicate 40 1 + sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) + (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert + in signedExact + +arbitraryX509WithKey (pubKey, _) = do + cert <- arbitraryCertificate pubKey + sig <- resize 40 $ listOf1 arbitrary + let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey) + let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert + return signedExact + arbitraryX509 = do - let pubKey = fst $ getGlobalRSAPair - arbitraryX509WithPublicKey pubKey + let (pubKey, privKey) = getGlobalRSAPair + arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) diff --git a/Tests/Ciphers.hs b/Tests/Ciphers.hs new file mode 100644 --- /dev/null +++ b/Tests/Ciphers.hs @@ -0,0 +1,38 @@ +module Ciphers + ( propertyBulkFunctional + ) where + +import Control.Applicative ((<$>), (<*>)) + +import Test.QuickCheck + +import qualified Data.ByteString as B +import Network.TLS.Cipher +import Network.TLS.Extra.Cipher + +arbitraryKey :: Bulk -> Gen B.ByteString +arbitraryKey bulk = B.pack `fmap` vector (fromIntegral $ bulkKeySize bulk) + +arbitraryIV :: Bulk -> Gen B.ByteString +arbitraryIV bulk = B.pack `fmap` vector (fromIntegral $ bulkIVSize bulk) + +arbitraryText :: Bulk -> Gen B.ByteString +arbitraryText bulk = B.pack `fmap` vector (fromIntegral $ bulkBlockSize bulk) + +data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString + deriving (Show,Eq) + +instance Arbitrary BulkTest where + arbitrary = do + bulk <- cipherBulk `fmap` elements ciphersuite_all + BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk + +propertyBulkFunctional :: BulkTest -> Bool +propertyBulkFunctional (BulkTest bulk key iv t) = + case bulkF bulk of + BulkBlockF enc dec -> block enc dec + BulkStreamF ktoi enc dec -> stream ktoi enc dec + where + block e d = (d key iv . e key iv) t == t + stream ktoi e d = (fst . d siv . fst . e siv) t == t + where siv = ktoi key diff --git a/Tests/Connection.hs b/Tests/Connection.hs --- a/Tests/Connection.hs +++ b/Tests/Connection.hs @@ -1,15 +1,24 @@ module Connection - ( newPairContext - , arbitraryPairParams - , setPairParamsSessionManager - , setPairParamsSessionResuming - ) where + ( newPairContext + , arbitraryPairParams + , setPairParamsSessionManager + , setPairParamsSessionResuming + , establishDataPipe + , blockCipher + , streamCipher + ) where import Test.QuickCheck import Certificate import PubKey import PipeChan import Network.TLS +import Data.X509 +import Data.Default.Class +import Control.Applicative +import Control.Concurrent.Chan +import Control.Concurrent +import qualified Control.Exception as E import qualified Crypto.Random.AESCtr as RNG import qualified Data.ByteString as B @@ -18,95 +27,140 @@ 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 + { 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 + } +blockCipherDHE_RSA :: Cipher +blockCipherDHE_RSA = blockCipher + { cipherID = 0xff14 + , cipherName = "dhe-rsa-id-const" + , cipherKeyExchange = CipherKeyExchange_DHE_RSA + } + +blockCipherDHE_DSS :: Cipher +blockCipherDHE_DSS = blockCipher + { cipherID = 0xff15 + , cipherName = "dhe-dss-id-const" + , cipherKeyExchange = CipherKeyExchange_DHE_DSS + } + +streamCipher :: Cipher streamCipher = blockCipher - { cipherID = 0xff13 - , cipherBulk = Bulk - { bulkName = "stream" - , bulkKeySize = 16 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = BulkStreamF (\k -> k) (\i m -> (m,i)) (\i m -> (m,i)) - } + { cipherID = 0xff13 + , cipherBulk = Bulk + { bulkName = "stream" + , bulkKeySize = 16 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = BulkStreamF (\k -> k) (\i m -> (m,i)) (\i m -> (m,i)) } + } -supportedCiphers :: [Cipher] -supportedCiphers = [blockCipher,streamCipher] +knownCiphers :: [Cipher] +knownCiphers = [blockCipher,blockCipherDHE_RSA,blockCipherDHE_DSS,streamCipher] -supportedVersions :: [Version] -supportedVersions = [SSL3,TLS10,TLS11,TLS12] +knownVersions :: [Version] +knownVersions = [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 + (dsaPub, dsaPriv) <- (\(p,r) -> (PubKeyDSA p, PrivKeyDSA r)) <$> arbitraryDSAPair + let (pubKey, privKey) = (\(p, r) -> (PubKeyRSA p, PrivKeyRSA r)) $ getGlobalRSAPair + creds <- mapM (\(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) [ (pubKey, privKey), (dsaPub, dsaPriv) ] + connectVersion <- elements knownVersions + let allowedVersions = [ v | v <- knownVersions, v <= connectVersion ] + serAllowedVersions <- (:[]) `fmap` elements allowedVersions + serverCiphers <- arbitraryCiphers + clientCiphers <- oneof [arbitraryCiphers] `suchThat` (\cs -> or [x `elem` serverCiphers | x <- cs]) + secNeg <- arbitrary - let serverState = 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) + let serverState = def + { serverSupported = def { supportedCiphers = serverCiphers + , supportedVersions = serAllowedVersions + , supportedSecureRenegotiation = secNeg + } + , serverDHEParams = Just dhParams + , serverShared = def { sharedCredentials = Credentials creds } + } + let clientState = (defaultParamsClient "" B.empty) + { clientSupported = def { supportedCiphers = clientCiphers + , supportedVersions = allowedVersions + , supportedSecureRenegotiation = secNeg + } + , clientShared = def { sharedValidationCache = ValidationCache + { cacheAdd = \_ _ _ -> return () + , cacheQuery = \_ _ _ -> return ValidationCachePass + } + } + } + return (clientState, serverState) + where + arbitraryCiphers = resize (length knownCiphers + 1) $ listOf1 (elements knownCiphers) + +setPairParamsSessionManager :: SessionManager -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionManager manager (clientState, serverState) = (nc,ns) - where - nc = setSessionManager manager clientState - ns = setSessionManager manager serverState + where nc = clientState { clientShared = updateSessionManager $ clientShared clientState } + ns = serverState { serverShared = updateSessionManager $ serverShared serverState } + updateSessionManager shared = shared { sharedSessionManager = manager } -setPairParamsSessionResuming sessionStuff (clientState, serverState) = (nc,serverState) - where - nc = updateClientParams (\cparams -> cparams { clientWantSessionResume = Just sessionStuff }) clientState +setPairParamsSessionResuming sessionStuff (clientState, serverState) = + ( clientState { clientWantSessionResume = Just sessionStuff } + , serverState) newPairContext pipe (cParams, sParams) = do - let noFlush = return () - let noClose = return () + let noFlush = return () + let noClose = return () - cRNG <- RNG.makeSystem - sRNG <- RNG.makeSystem + 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 + 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') + contextHookSetLogging cCtx' (logging "client: ") + contextHookSetLogging sCtx' (logging "server: ") + + return (cCtx', sCtx') + where + logging pre = + if debug + then def { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) + , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } + else def + +establishDataPipe params tlsServer tlsClient = do + -- initial setup + pipe <- newPipe + _ <- (runPipe pipe) + startQueue <- newChan + resultQueue <- newChan + + (cCtx, sCtx) <- newPairContext pipe params + + _ <- forkIO $ E.catch (tlsServer sCtx resultQueue) (printAndRaise "server") + _ <- forkIO $ E.catch (tlsClient startQueue cCtx) (printAndRaise "client") + + return (startQueue, resultQueue) + where + printAndRaise :: String -> E.SomeException -> IO () + printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> E.throw e diff --git a/Tests/Marshalling.hs b/Tests/Marshalling.hs new file mode 100644 --- /dev/null +++ b/Tests/Marshalling.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +module Marshalling where + +import Control.Monad +import Control.Applicative +import Test.QuickCheck +import Network.TLS.Internal +import Network.TLS + +import qualified Data.ByteString as B +import Data.Word +import Data.X509 +import Certificate + +genByteString :: Int -> Gen B.ByteString +genByteString i = B.pack <$> vector i + +instance Arbitrary Version where + arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ] + +instance Arbitrary ProtocolType where + arbitrary = elements + [ ProtocolType_ChangeCipherSpec + , ProtocolType_Alert + , ProtocolType_Handshake + , ProtocolType_AppData ] + +#if MIN_VERSION_QuickCheck(2,3,0) +#else +instance Arbitrary Word8 where + arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int) + +instance Arbitrary Word16 where + arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int) +#endif + +instance Arbitrary Header where + arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ClientRandom where + arbitrary = ClientRandom <$> (genByteString 32) + +instance Arbitrary ServerRandom where + arbitrary = ServerRandom <$> (genByteString 32) + +instance Arbitrary Session where + arbitrary = do + i <- choose (1,2) :: Gen Int + case i of + 2 -> liftM (Session . Just) (genByteString 32) + _ -> return $ Session Nothing + +instance Arbitrary DigitallySigned where + arbitrary = DigitallySigned Nothing <$> genByteString 32 + +arbitraryCiphersIDs :: Gen [Word16] +arbitraryCiphersIDs = choose (0,200) >>= vector + +arbitraryCompressionIDs :: Gen [Word8] +arbitraryCompressionIDs = choose (0,200) >>= vector + +someWords8 :: Int -> Gen [Word8] +someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int)) + +instance Arbitrary CertificateType where + arbitrary = elements + [ CertificateType_RSA_Sign, CertificateType_DSS_Sign + , CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH + , CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH + , CertificateType_fortezza_dms ] + +instance Arbitrary Handshake where + arbitrary = oneof + [ ClientHello + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryCiphersIDs + <*> arbitraryCompressionIDs + <*> (return []) + <*> (return Nothing) + , ServerHello + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (return []) + , liftM Certificates (CertificateChain <$> (resize 2 $ listOf $ arbitraryX509)) + , pure HelloRequest + , pure ServerHelloDone + , ClientKeyXchg . CKX_RSA <$> genByteString 48 + --, liftM ServerKeyXchg + , liftM3 CertRequest arbitrary (return Nothing) (return []) + , CertVerify <$> arbitrary + , Finished <$> (genByteString 12) + ] + +{- quickcheck property -} + +prop_header_marshalling_id :: Header -> Bool +prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x + +prop_handshake_marshalling_id :: Handshake -> Bool +prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x + where decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b + cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA, cParamsSupportNPN = True } diff --git a/Tests/PipeChan.hs b/Tests/PipeChan.hs --- a/Tests/PipeChan.hs +++ b/Tests/PipeChan.hs @@ -1,13 +1,13 @@ -- create a similar concept than a unix pipe. module PipeChan - ( PipeChan(..) - , newPipe - , runPipe - , readPipeA - , readPipeB - , writePipeA - , writePipeB - ) where + ( PipeChan(..) + , newPipe + , runPipe + , readPipeA + , readPipeB + , writePipeA + , writePipeB + ) where import Control.Applicative import Control.Concurrent.Chan @@ -42,15 +42,15 @@ -- 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) + 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 --- a/Tests/PubKey.hs +++ b/Tests/PubKey.hs @@ -1,14 +1,20 @@ module PubKey - ( arbitraryRSAPair - , globalRSAPair - , getGlobalRSAPair - ) where + ( arbitraryRSAPair + , arbitraryDSAPair + , globalRSAPair + , getGlobalRSAPair + , dhParams + , dsaParams + , rsaParams + ) where import Test.QuickCheck +import qualified Crypto.PubKey.DH as DH import Crypto.Random (createTestEntropyPool) import qualified Crypto.Random.AESCtr as RNG import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.DSA as DSA import qualified Data.ByteString as B @@ -17,8 +23,8 @@ arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) arbitraryRSAPair = do - rng <- (RNG.make . createTestEntropyPool . B.pack) `fmap` vector 64 - arbitraryRSAPairWithRNG rng + rng <- (RNG.make . createTestEntropyPool . B.pack) `fmap` vector 1024 + arbitraryRSAPairWithRNG rng arbitraryRSAPairWithRNG rng = return $ fst $ RSA.generate rng 128 0x10001 @@ -29,3 +35,37 @@ {-# NOINLINE getGlobalRSAPair #-} getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) + +rsaParams :: (RSA.PublicKey, RSA.PrivateKey) +rsaParams = (pub, priv) + where priv = RSA.PrivateKey { RSA.private_pub = pub + , RSA.private_d = d + , RSA.private_p = 0 + , RSA.private_q = 0 + , RSA.private_dP = 0 + , RSA.private_dQ = 0 + , RSA.private_qinv = 0 + } + pub = RSA.PublicKey { RSA.public_size = (1024 `div` 8), RSA.public_n = n, RSA.public_e = e } + n = 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7 + e = 0x10001 + d = 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 + +dhParams :: DH.Params +dhParams = DH.Params + { DH.params_p = 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb + , DH.params_g = 0x2 + } + +dsaParams :: DSA.Params +dsaParams = DSA.Params + { DSA.params_p = 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb + , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b + , DSA.params_g = 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff + } + +arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) +arbitraryDSAPair = do + priv <- choose (1, DSA.params_q dsaParams) + let pub = DSA.calculatePublic dsaParams priv + return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv) diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -5,326 +5,178 @@ import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Certificate import PipeChan import Connection +import Marshalling +import Ciphers import Data.Maybe -import Data.Word import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Network.TLS -import Network.TLS.Internal import Control.Applicative import Control.Concurrent -import Control.Exception (throw, SomeException) -import qualified Control.Exception as E import Control.Monad import Data.IORef -genByteString :: Int -> Gen B.ByteString -genByteString i = B.pack <$> vector i - -instance Arbitrary Version where - arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ] - -instance Arbitrary ProtocolType where - arbitrary = elements - [ ProtocolType_ChangeCipherSpec - , ProtocolType_Alert - , ProtocolType_Handshake - , ProtocolType_AppData ] - -#if MIN_VERSION_QuickCheck(2,3,0) -#else -instance Arbitrary Word8 where - arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int) - -instance Arbitrary Word16 where - arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int) -#endif - -instance Arbitrary Header where - arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary ClientRandom where - arbitrary = ClientRandom <$> (genByteString 32) - -instance Arbitrary ServerRandom where - arbitrary = ServerRandom <$> (genByteString 32) - -instance Arbitrary Session where - arbitrary = do - i <- choose (1,2) :: Gen Int - case i of - 2 -> liftM (Session . Just) (genByteString 32) - _ -> return $ Session Nothing - -instance Arbitrary CertVerifyData where - arbitrary = do - liftM CertVerifyData (genByteString 128) - -arbitraryCiphersIDs :: Gen [Word16] -arbitraryCiphersIDs = choose (0,200) >>= vector - -arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0,200) >>= vector - -someWords8 :: Int -> Gen [Word8] -someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int)) - -instance Arbitrary CertificateType where - arbitrary = elements - [ CertificateType_RSA_Sign, CertificateType_DSS_Sign - , CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH - , CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH - , CertificateType_fortezza_dms ] - -instance Arbitrary Handshake where - arbitrary = oneof - [ ClientHello - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryCiphersIDs - <*> arbitraryCompressionIDs - <*> (return []) - <*> (return Nothing) - , ServerHello - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (return []) - , liftM Certificates (resize 2 $ listOf $ arbitraryX509) - , pure HelloRequest - , pure ServerHelloDone - , ClientKeyXchg <$> genByteString 48 - --, liftM ServerKeyXchg - , liftM3 CertRequest arbitrary (return Nothing) (return []) - , liftM2 CertVerify (return Nothing) arbitrary - , Finished <$> (genByteString 12) - ] - -{- quickcheck property -} - -prop_header_marshalling_id :: Header -> Bool -prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x - -prop_handshake_marshalling_id :: Handshake -> Bool -prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x - where - decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b - cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA, cParamsSupportNPN = True } - prop_pipe_work :: PropertyM IO () prop_pipe_work = do - pipe <- run newPipe - _ <- run (runPipe pipe) - - let bSize = 16 - n <- pick (choose (1, 32)) - - let d1 = B.replicate (bSize * n) 40 - let d2 = B.replicate (bSize * n) 45 - - d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) - d1 `assertEq` d1' - - d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) - d2 `assertEq` d2' + pipe <- run newPipe + _ <- run (runPipe pipe) - return () + let bSize = 16 + n <- pick (choose (1, 32)) -establish_data_pipe params tlsServer tlsClient = do - -- initial setup - pipe <- newPipe - _ <- (runPipe pipe) - startQueue <- newChan - resultQueue <- newChan + let d1 = B.replicate (bSize * n) 40 + let d2 = B.replicate (bSize * n) 45 - (cCtx, sCtx) <- newPairContext pipe params + d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) + d1 `assertEq` d1' - _ <- forkIO $ E.catch (tlsServer sCtx resultQueue) (printAndRaise "server") - _ <- forkIO $ E.catch (tlsClient startQueue cCtx) (printAndRaise "client") + d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) + d2 `assertEq` d2' - return (startQueue, resultQueue) - where - printAndRaise :: String -> SomeException -> IO () - printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e + return () recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l +runTLSPipe params tlsServer tlsClient = do + (startQueue, resultQueue) <- run (establishDataPipe params tlsServer tlsClient) + -- send some data + d <- B.pack <$> pick (someWords8 256) + run $ writeChan startQueue d + -- receive it + dres <- run $ readChan resultQueue + -- check if it equal + d `assertEq` dres + return () + prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do - params <- pick arbitraryPairParams - (startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient) - - {- the test involves writing data on one side of the data "pipe" and - - then checking we received them on the other side of the data "pipe" -} - d <- B.pack <$> pick (someWords8 256) - run $ writeChan startQueue d - - dres <- run $ readChan resultQueue - d `assertEq` dres - - return () - where - tlsServer ctx queue = do - handshake ctx - d <- recvDataNonNull ctx - writeChan queue d - return () - tlsClient queue ctx = do - handshake ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - bye ctx - return () + params <- pick arbitraryPairParams + runTLSPipe params tlsServer tlsClient + where tlsServer ctx queue = do + handshake ctx + d <- recvDataNonNull ctx + writeChan queue d + return () + tlsClient queue ctx = do + handshake ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + bye ctx + return () prop_handshake_npn_initiate :: PropertyM IO () prop_handshake_npn_initiate = do - (clientParam,serverParam) <- pick arbitraryPairParams - let clientParam' = clientParam { 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 () + (clientParam,serverParam) <- pick arbitraryPairParams + let clientParam' = clientParam { clientHooks = (clientHooks clientParam) + { onNPNServerSuggest = Just $ \protos -> return (head protos) } + } + serverParam' = serverParam { serverHooks = (serverHooks serverParam) + { onSuggestNextProtocols = return $ Just [C8.pack "spdy/2", C8.pack "http/1.1"] } + } + params' = (clientParam',serverParam') + runTLSPipe params' tlsServer tlsClient + where tlsServer ctx queue = do + handshake ctx + proto <- getNegotiatedProtocol ctx + Just (C8.pack "spdy/2") `assertEq` proto + d <- recvDataNonNull ctx + writeChan queue d + return () + tlsClient queue ctx = do + handshake ctx + proto <- getNegotiatedProtocol ctx + Just (C8.pack "spdy/2") `assertEq` proto + d <- readChan queue + sendData ctx (L.fromChunks [d]) + bye ctx + return () prop_handshake_renegociation :: PropertyM IO () prop_handshake_renegociation = do - params <- pick arbitraryPairParams - (startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient) - - {- the test involves writing data on one side of the data "pipe" and - - then checking we received them on the other side of the data "pipe" -} - d <- B.pack <$> pick (someWords8 256) - run $ writeChan startQueue d - - dres <- run $ readChan resultQueue - d `assertEq` dres - - return () - where - tlsServer ctx queue = do - handshake ctx - d <- recvDataNonNull ctx - writeChan queue d - return () - tlsClient queue ctx = do - handshake ctx - handshake ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - bye ctx - return () + params <- pick arbitraryPairParams + runTLSPipe params tlsServer tlsClient + where tlsServer ctx queue = do + handshake ctx + d <- recvDataNonNull ctx + writeChan queue d + return () + tlsClient queue ctx = do + handshake ctx + 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) +oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager +oneSessionManager ref = SessionManager + { sessionResume = \myId -> (>>= maybeResume myId) <$> readIORef ref + , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) + , sessionInvalidate = \_ -> return () + } + where + maybeResume myId (sid, sdata) + | sid == myId = Just sdata + | otherwise = Nothing prop_handshake_session_resumption :: PropertyM IO () prop_handshake_session_resumption = do - sessionRef <- run $ newIORef Nothing - let sessionManager = OneSessionManager sessionRef - - plainParams <- pick arbitraryPairParams - let params = setPairParamsSessionManager sessionManager plainParams - - -- establish a session. - (s1, r1) <- run (establish_data_pipe params tlsServer tlsClient) - - d <- B.pack <$> pick (someWords8 256) - run $ writeChan s1 d - dres <- run $ readChan r1 - d `assertEq` dres - - -- and resume - sessionParams <- run $ readIORef sessionRef - assert (isJust sessionParams) - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + sessionRef <- run $ newIORef Nothing + let sessionManager = oneSessionManager sessionRef - -- resume - (startQueue, resultQueue) <- run (establish_data_pipe params2 tlsServer tlsClient) + plainParams <- pick arbitraryPairParams + let params = setPairParamsSessionManager sessionManager plainParams - {- 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 + runTLSPipe params tlsServer tlsClient - dres2 <- run $ readChan resultQueue - d2 `assertEq` dres2 + -- and resume + sessionParams <- run $ readIORef sessionRef + assert (isJust sessionParams) + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - 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 () + runTLSPipe params2 tlsServer tlsClient + where tlsServer ctx queue = do + handshake ctx + d <- recvDataNonNull ctx + writeChan queue d + return () + tlsClient queue ctx = do + handshake ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + bye ctx + return () assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) main :: IO () main = defaultMain - [ 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_ciphers + , tests_handshake + ] + where -- lowlevel tests to check the packet marshalling. + tests_marshalling = testGroup "Marshalling" + [ testProperty "Header" prop_header_marshalling_id + , testProperty "Handshake" prop_handshake_marshalling_id + ] + tests_ciphers = testGroup "Ciphers" + [ testProperty "Bulk" propertyBulkFunctional ] - -- high level tests between a client and server with fake ciphers. - tests_handshake = testGroup "Handshakes" - [ testProperty "setup" (monadicIO prop_pipe_work) - , testProperty "initiate" (monadicIO prop_handshake_initiate) - , testProperty "initiate with npn" (monadicIO prop_handshake_npn_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 "npnInitiate" (monadicIO prop_handshake_npn_initiate) + , testProperty "renegociation" (monadicIO prop_handshake_renegociation) + , testProperty "resumption" (monadicIO prop_handshake_session_resumption) + ] diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 1.1.5 +Version: 1.2.0 Description: Native Haskell TLS and SSL protocol implementation for server and client. . @@ -33,45 +33,72 @@ Library Build-Depends: base >= 3 && < 5 , mtl - , cryptohash >= 0.6 , cereal >= 0.3 , bytestring , network - , crypto-random >= 0.0.7 && < 0.1 - , crypto-pubkey >= 0.2 - , certificate >= 1.3.0 && < 1.4.0 + , data-default-class + -- crypto related + , cryptohash >= 0.6 + , crypto-random >= 0.0 && < 0.1 + , crypto-numbers + , crypto-pubkey-types >= 0.4 + , crypto-pubkey >= 0.2.4 + , cipher-rc4 + , cipher-aes >= 0.2 && < 0.3 + -- certificate related + , asn1-types >= 0.2.0 + , asn1-encoding + , x509 >= 1.4.3 && < 1.5.0 + , x509-store + , x509-validation >= 1.5.0 && < 1.6.0 Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression Network.TLS.Internal + Network.TLS.Extra + Network.TLS.Extra.Cipher other-modules: Network.TLS.Cap Network.TLS.Struct Network.TLS.Core Network.TLS.Context + Network.TLS.Context.Internal + Network.TLS.Credentials + Network.TLS.Backend Network.TLS.Crypto + Network.TLS.Crypto.DH Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Common Network.TLS.Handshake.Certificate + Network.TLS.Handshake.Key Network.TLS.Handshake.Client Network.TLS.Handshake.Server + Network.TLS.Handshake.Process Network.TLS.Handshake.Signature + Network.TLS.Handshake.State + Network.TLS.Hooks Network.TLS.IO Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet + Network.TLS.Parameters Network.TLS.Record Network.TLS.Record.Types Network.TLS.Record.Engage Network.TLS.Record.Disengage + Network.TLS.Record.State + Network.TLS.RNG Network.TLS.State Network.TLS.Session Network.TLS.Sending Network.TLS.Receiving Network.TLS.Util + Network.TLS.Util.ASN1 + Network.TLS.Util.Serialization Network.TLS.Types Network.TLS.Wire - ghc-options: -Wall + Network.TLS.X509 + ghc-options: -Wall -fwarn-tabs if impl(ghc == 7.6.1) ghc-options: -O0 if flag(compat) @@ -84,18 +111,40 @@ Build-Depends: base >= 3 && < 5 , mtl , cereal >= 0.3 + , data-default-class , QuickCheck >= 2 , test-framework , test-framework-quickcheck2 , cprng-aes >= 0.5 - , crypto-pubkey + , crypto-pubkey >= 0.2 , bytestring - , certificate + , x509 + , x509-validation , tls , time - , crypto-random >= 0.0.2 && < 0.1 - ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + , crypto-random + , crypto-pubkey + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fwarn-tabs +Benchmark bench-tls + hs-source-dirs: Benchmarks Tests + Main-Is: Benchmarks.hs + type: exitcode-stdio-1.0 + Build-depends: base >= 4 && < 5 + , tls + , x509 + , x509-validation + , data-default-class + , crypto-random + , criterion + , cprng-aes + , mtl + , bytestring + , crypto-pubkey >= 0.2 + , time + , QuickCheck >= 2 + source-repository head type: git location: git://github.com/vincenthz/hs-tls + subdir: core