tls 1.1.5 → 1.2.0
raw patch · 55 files changed
+4859/−3039 lines, 55 filesdep +asn1-encodingdep +asn1-typesdep +cipher-aesdep −certificatedep ~basedep ~cprng-aesdep ~crypto-pubkey
Dependencies added: asn1-encoding, asn1-types, cipher-aes, cipher-rc4, criterion, crypto-numbers, crypto-pubkey-types, data-default-class, x509, x509-store, x509-validation
Dependencies removed: certificate
Dependency ranges changed: base, cprng-aes, crypto-pubkey, crypto-random
Files
- Benchmarks/Benchmarks.hs +64/−0
- Network/TLS.hs +45/−23
- Network/TLS/Backend.hs +57/−0
- Network/TLS/Cap.hs +3/−3
- Network/TLS/Cipher.hs +70/−47
- Network/TLS/Compression.hs +21/−19
- Network/TLS/Context.hs +175/−350
- Network/TLS/Context/Internal.hs +223/−0
- Network/TLS/Core.hs +57/−56
- Network/TLS/Credentials.hs +90/−0
- Network/TLS/Crypto.hs +100/−53
- Network/TLS/Crypto/DH.hs +53/−0
- Network/TLS/Extension.hs +6/−7
- Network/TLS/Extra.hs +13/−0
- Network/TLS/Extra/Cipher.hs +394/−0
- Network/TLS/Handshake.hs +11/−15
- Network/TLS/Handshake/Certificate.hs +3/−2
- Network/TLS/Handshake/Client.hs +257/−191
- Network/TLS/Handshake/Common.hs +76/−74
- Network/TLS/Handshake/Key.hs +62/−0
- Network/TLS/Handshake/Process.hs +109/−0
- Network/TLS/Handshake/Server.hs +264/−215
- Network/TLS/Handshake/Signature.hs +83/−3
- Network/TLS/Handshake/State.hs +262/−0
- Network/TLS/Hooks.hs +58/−0
- Network/TLS/IO.hs +64/−57
- Network/TLS/Internal.hs +7/−7
- Network/TLS/MAC.hs +28/−32
- Network/TLS/Packet.hs +301/−285
- Network/TLS/Parameters.hs +243/−0
- Network/TLS/RNG.hs +17/−0
- Network/TLS/Receiving.hs +33/−130
- Network/TLS/Record.hs +24/−14
- Network/TLS/Record/Disengage.hs +46/−47
- Network/TLS/Record/Engage.hs +43/−47
- Network/TLS/Record/State.hs +130/−0
- Network/TLS/Record/Types.hs +31/−31
- Network/TLS/Sending.hs +62/−79
- Network/TLS/Session.hs +15/−15
- Network/TLS/State.hs +118/−424
- Network/TLS/Struct.hs +334/−317
- Network/TLS/Types.hs +19/−4
- Network/TLS/Util.hs +33/−17
- Network/TLS/Util/ASN1.hs +37/−0
- Network/TLS/Util/Serialization.hs +6/−0
- Network/TLS/Wire.hs +53/−44
- Network/TLS/X509.hs +59/−0
- Tests/Certificate.hs +71/−42
- Tests/Ciphers.hs +38/−0
- Tests/Connection.hs +134/−80
- Tests/Marshalling.hs +107/−0
- Tests/PipeChan.hs +20/−20
- Tests/PubKey.hs +46/−6
- Tests/Tests.hs +125/−273
- tls.cabal +59/−10
+ Benchmarks/Benchmarks.hs view
@@ -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"+ ]+ ]
Network/TLS.hs view
@@ -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
+ Network/TLS/Backend.hs view
@@ -0,0 +1,57 @@+-- |+-- Module : Network.TLS.Backend+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
Network/TLS/Cap.hs view
@@ -7,9 +7,9 @@ -- module Network.TLS.Cap- ( hasHelloExtensions- , hasExplicitBlockIV- ) where+ ( hasHelloExtensions+ , hasExplicitBlockIV+ ) where import Network.TLS.Struct
Network/TLS/Cipher.hs view
@@ -8,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
Network/TLS/Compression.hs view
@@ -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
Network/TLS/Context.hs view
@@ -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 })
+ Network/TLS/Context/Internal.hs view
@@ -0,0 +1,223 @@+-- |+-- Module : Network.TLS.Context.Internal+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
Network/TLS/Core.hs view
@@ -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.
+ Network/TLS/Credentials.hs view
@@ -0,0 +1,90 @@+-- |+-- Module : Network.TLS.Credentials+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
Network/TLS/Crypto.hs view
@@ -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)
+ Network/TLS/Crypto/DH.hs view
@@ -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
Network/TLS/Extension.hs view
@@ -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]
+ Network/TLS/Extra.hs view
@@ -0,0 +1,13 @@+-- |+-- Module : Network.TLS.Extra+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- default values and ciphers+module Network.TLS.Extra+ ( module Network.TLS.Extra.Cipher+ ) where++import Network.TLS.Extra.Cipher
+ Network/TLS/Extra/Cipher.hs view
@@ -0,0 +1,394 @@+-- |+-- Module : Network.TLS.Extra.Cipher+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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:+ <http://www.thesprawl.org/research/tls-and-ssl-cipher-suites/>++-}
Network/TLS/Handshake.hs view
@@ -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
Network/TLS/Handshake/Certificate.hs view
@@ -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
Network/TLS/Handshake/Client.hs view
@@ -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")
Network/TLS/Handshake/Common.hs view
@@ -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+ }
+ Network/TLS/Handshake/Key.hs view
@@ -0,0 +1,62 @@+-- |+-- Module : Network.TLS.Handshake.Key+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Network/TLS/Handshake/Process.hs view
@@ -0,0 +1,109 @@+-- |+-- Module : Network.TLS.Handshake.Process+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
Network/TLS/Handshake/Server.hs view
@@ -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
Network/TLS/Handshake/Signature.hs view
@@ -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
+ Network/TLS/Handshake/State.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+-- |+-- Module : Network.TLS.Handshake.State+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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"
+ Network/TLS/Hooks.hs view
@@ -0,0 +1,58 @@+-- |+-- Module : Network.TLS.Context+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
Network/TLS/IO.hs view
@@ -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
Network/TLS/Internal.hs view
@@ -7,13 +7,13 @@ -- Portability : unknown -- module Network.TLS.Internal- ( module Network.TLS.Struct- , module Network.TLS.Packet- , module Network.TLS.Receiving- , module Network.TLS.Sending- , sendPacket- , recvPacket- ) where+ ( module Network.TLS.Struct+ , module Network.TLS.Packet+ , module Network.TLS.Receiving+ , module Network.TLS.Sending+ , sendPacket+ , recvPacket+ ) where import Network.TLS.Struct import Network.TLS.Packet
Network/TLS/MAC.hs view
@@ -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
Network/TLS/Packet.hs view
@@ -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
+ Network/TLS/Parameters.hs view
@@ -0,0 +1,243 @@+-- |+-- Module : Network.TLS.Parameters+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Network/TLS/RNG.hs view
@@ -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')+
Network/TLS/Receiving.hs view
@@ -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)
Network/TLS/Record.hs view
@@ -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
Network/TLS/Record/Disengage.hs view
@@ -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)
Network/TLS/Record/Engage.hs view
@@ -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
+ Network/TLS/Record/State.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+-- |+-- Module : Network.TLS.Record.State+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
Network/TLS/Record/Types.hs view
@@ -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
Network/TLS/Sending.hs view
@@ -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)
Network/TLS/Session.hs view
@@ -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 ()+ }
Network/TLS/State.hs view
@@ -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
Network/TLS/Struct.hs view
@@ -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)
Network/TLS/Types.hs view
@@ -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
Network/TLS/Util.hs view
@@ -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
+ Network/TLS/Util/ASN1.hs view
@@ -0,0 +1,37 @@+-- |+-- Module : Network.TLS.Util.ASN1+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 []
+ Network/TLS/Util/Serialization.hs view
@@ -0,0 +1,6 @@+module Network.TLS.Util.Serialization+ ( os2ip+ , i2osp+ ) where++import Crypto.Number.Serialize (os2ip, i2osp)
Network/TLS/Wire.hs view
@@ -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
+ Network/TLS/X509.hs view
@@ -0,0 +1,59 @@+-- |+-- Module : Network.TLS.X509+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
Tests/Certificate.hs view
@@ -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)
+ Tests/Ciphers.hs view
@@ -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
Tests/Connection.hs view
@@ -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
+ Tests/Marshalling.hs view
@@ -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 }
Tests/PipeChan.hs view
@@ -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)
Tests/PubKey.hs view
@@ -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)
Tests/Tests.hs view
@@ -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)+ ]
tls.cabal view
@@ -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