packages feed

tls 0.7.2 → 0.8.0

raw patch · 18 files changed

+567/−326 lines, 18 filesdep ~certificate

Dependency ranges changed: certificate

Files

Network/TLS.hs view
@@ -17,7 +17,7 @@  	-- * Context object 	, TLSCtx-	, ctxHandle+	, ctxConnection  	-- * Creating a context 	, client@@ -34,10 +34,12 @@ 	-- * Crypto Key 	, PrivateKey(..) 	-- * Compressions & Predefined compressions-	, Compression+	, CompressionC(..)+	, Compression(..) 	, nullCompression 	-- * Ciphers & Predefined ciphers-	, Cipher+	, Cipher(..)+	, Bulk(..) 	-- * Versions 	, Version(..) 	-- * Errors@@ -46,6 +48,6 @@  import Network.TLS.Struct (Version(..), TLSError(..)) import Network.TLS.Crypto (PrivateKey(..))-import Network.TLS.Cipher (Cipher(..))-import Network.TLS.Compression (Compression(..), nullCompression)+import Network.TLS.Cipher (Cipher(..), Bulk(..))+import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) import Network.TLS.Core
Network/TLS/Cipher.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ExistentialQuantification #-} -- | -- Module      : Network.TLS.Cipher -- License     : BSD-style@@ -7,9 +8,12 @@ -- Portability : unknown -- module Network.TLS.Cipher-	( CipherTypeFunctions(..)+	( BulkFunctions(..) 	, CipherKeyExchangeType(..)+	, Bulk(..)+	, Hash(..) 	, Cipher(..)+	, cipherKeyBlockSize 	, Key 	, IV 	, cipherExchangeNeedMoreData@@ -24,13 +28,13 @@ type Key = B.ByteString type IV = B.ByteString -data CipherTypeFunctions =-	  CipherNoneF -- special value for 0-	| CipherBlockF (Key -> IV -> B.ByteString -> B.ByteString)-	               (Key -> IV -> B.ByteString -> B.ByteString)-	| CipherStreamF (Key -> IV)-	                (IV -> B.ByteString -> (B.ByteString, IV))-	                (IV -> B.ByteString -> (B.ByteString, IV))+data BulkFunctions =+	  BulkNoneF -- special value for 0+	| BulkBlockF (Key -> IV -> B.ByteString -> B.ByteString)+	             (Key -> IV -> B.ByteString -> B.ByteString)+	| BulkStreamF (Key -> IV)+	              (IV -> B.ByteString -> (B.ByteString, IV))+	              (IV -> B.ByteString -> (B.ByteString, IV))  data CipherKeyExchangeType = 	  CipherKeyExchange_RSA@@ -45,20 +49,33 @@ 	| CipherKeyExchange_ECDHE_ECDSA 	deriving (Show,Eq) +data Bulk = Bulk+	{ bulkName         :: String+	, bulkKeySize      :: Int+	, bulkIVSize       :: Int+	, bulkBlockSize    :: Int+	, bulkF            :: BulkFunctions+	}++data Hash = Hash+	{ hashName         :: String+	, hashSize         :: Int+	, hashF            :: B.ByteString -> B.ByteString+	}+ -- | Cipher algorithm data Cipher = Cipher 	{ cipherID           :: Word16 	, cipherName         :: String-	, cipherDigestSize   :: Word8-	, cipherKeySize      :: Word8-	, cipherIVSize       :: Word8-	, cipherKeyBlockSize :: Word8-	, cipherPaddingSize  :: Word8+	, cipherHash         :: Hash+	, cipherBulk         :: Bulk 	, cipherKeyExchange  :: CipherKeyExchangeType-	, cipherMACHash      :: B.ByteString -> B.ByteString-	, cipherF            :: CipherTypeFunctions 	, cipherMinVer       :: Maybe Version 	}++cipherKeyBlockSize :: Cipher -> Int+cipherKeyBlockSize cipher = 2 * (hashSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk)+	where bulk = cipherBulk cipher  instance Show Cipher where 	show c = cipherName c
Network/TLS/Compression.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ExistentialQuantification #-} -- | -- Module      : Network.TLS.Compression -- License     : BSD-style@@ -7,22 +8,62 @@ -- Portability : unknown -- module Network.TLS.Compression-	( Compression(..)+	( CompressionC(..)+	, Compression(..) 	, nullCompression++	-- * member redefined for the class abstraction+	, compressionID+	, compressionDeflate+	, compressionInflate++	-- * helper+	, compressionIntersectID 	) where  import Data.Word import Data.ByteString (ByteString)+import Control.Arrow (first) --- | Compression algorithm-data Compression = Compression-	{ compressionID :: Word8-	, compressionFct :: (ByteString -> ByteString)-	}+-- | supported compression algorithms need to be part of this class+class CompressionC a where+	compressionCID      :: a -> Word8+	compressionCDeflate :: a -> ByteString -> (a, ByteString)+	compressionCInflate :: a -> ByteString -> (a, ByteString) +-- | every compression need to be wrapped in this, to fit in structure+data Compression = forall a . CompressionC a => Compression a++-- | return the associated ID for this algorithm+compressionID :: Compression -> Word8+compressionID (Compression c) = compressionCID c++-- | deflate (compress) a bytestring using a compression context and return the result+-- along with the new compression context.+compressionDeflate :: ByteString -> Compression -> (Compression, ByteString)+compressionDeflate bytes (Compression c) = first Compression $ compressionCDeflate c bytes++-- | inflate (decompress) a bytestring using a compression context and return the result+-- along the new compression context.+compressionInflate :: ByteString -> Compression -> (Compression, ByteString)+compressionInflate bytes (Compression c) = first Compression $ compressionCInflate c bytes+ instance Show Compression where 	show = show . compressionID +-- | intersect a list of ids commonly given by the other side with a list of compression+-- the function keeps the list of compression in order, to be able to find quickly the prefered+-- compression.+compressionIntersectID :: [Compression] -> [Word8] -> [Compression]+compressionIntersectID l ids = filter (\c -> elem (compressionID c) ids) l++data NullCompression = NullCompression++instance CompressionC NullCompression where+	compressionCID _         = 0+	compressionCDeflate s b = (s, b)+	compressionCInflate s b = (s, b)+ -- | default null compression nullCompression :: Compression-nullCompression = Compression { compressionID = 0, compressionFct = id }+nullCompression = Compression NullCompression
Network/TLS/Core.hs view
@@ -18,7 +18,7 @@  	-- * Context object 	, TLSCtx-	, ctxHandle+	, ctxConnection 	, ctxEOF  	-- * Internal packet sending and receiving@@ -27,7 +27,9 @@  	-- * Creating a context 	, client+	, clientWith 	, server+	, serverWith  	-- * Initialisation and Termination of context 	, bye@@ -39,6 +41,7 @@ 	) where  import Network.TLS.Struct+import Network.TLS.Record import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Crypto@@ -93,7 +96,7 @@ 	, pUseSecureRenegotiation :: Bool           -- notify that we want to use secure renegotation 	, pCertificates      :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any. 	, pLogging           :: TLSLogging          -- ^ callback for logging-	, onCertificatesRecv :: ([X509] -> IO TLSCertificateUsage) -- ^ callback to verify received cert chain.+	, onCertificatesRecv :: [X509] -> IO TLSCertificateUsage -- ^ callback to verify received cert chain. 	}  defaultLogging :: TLSLogging@@ -107,7 +110,7 @@ defaultParams :: TLSParams defaultParams = TLSParams 	{ pConnectVersion         = TLS10-	, pAllowedVersions        = [TLS10,TLS11]+	, pAllowedVersions        = [TLS10,TLS11,TLS12] 	, pCiphers                = [] 	, pCompressions           = [nullCompression] 	, pWantClientCert         = False@@ -128,35 +131,54 @@ 		]) ++ " }"  -- | A TLS Context is a handle augmented by tls specific state and parameters-data TLSCtx = TLSCtx-	{ ctxHandle :: Handle        -- ^ return the handle associated with this context-	, ctxParams :: TLSParams-	, ctxState  :: MVar TLSState-	, ctxEOF_   :: IORef Bool    -- ^ is the handle as EOFed or not.+data TLSCtx a = TLSCtx+	{ ctxConnection      :: a             -- ^ return the connection object associated with this context+	, ctxParams          :: TLSParams+	, ctxState           :: MVar TLSState+	, ctxEOF_            :: IORef Bool    -- ^ is the handle has EOFed or not.+	, ctxConnectionFlush :: IO ()+	, ctxConnectionSend  :: Bytes -> IO ()+	, ctxConnectionRecv  :: Int -> IO Bytes 	} -ctxEOF :: MonadIO m => TLSCtx -> m Bool+connectionFlush :: TLSCtx c -> IO ()+connectionFlush c = (ctxConnectionFlush c)++connectionSend :: TLSCtx c -> Bytes -> IO ()+connectionSend c b = (ctxConnectionSend c) b++connectionRecv :: TLSCtx c -> Int -> IO Bytes+connectionRecv c sz = (ctxConnectionRecv c) sz++ctxEOF :: MonadIO m => TLSCtx a -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx)  throwCore :: (MonadIO m, Exception e) => e -> m a throwCore = liftIO . throwIO -newCtx :: Handle -> TLSParams -> TLSState -> IO TLSCtx-newCtx handle params st = do-	hSetBuffering handle NoBuffering+newCtxWith :: c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> TLSParams -> TLSState -> IO (TLSCtx c)+newCtxWith c flushF sendF recvF params st = do 	stvar <- newMVar st 	eof   <- newIORef False 	return $ TLSCtx-		{ ctxHandle = handle-		, ctxParams = params-		, ctxState  = stvar-		, ctxEOF_   = eof+		{ ctxConnection = c+		, ctxParams     = params+		, ctxState      = stvar+		, ctxEOF_       = eof+		, ctxConnectionFlush = flushF+		, ctxConnectionSend  = sendF+		, ctxConnectionRecv  = recvF 		} -ctxLogging :: TLSCtx -> TLSLogging+newCtx :: Handle -> TLSParams -> TLSState -> IO (TLSCtx Handle)+newCtx handle params st = do+	hSetBuffering handle NoBuffering+	newCtxWith handle (hFlush handle) (B.hPut handle) (B.hGet handle) params st++ctxLogging :: TLSCtx a -> TLSLogging ctxLogging = pLogging . ctxParams -usingState :: MonadIO m => TLSCtx -> TLSSt a -> m (Either TLSError a)+usingState :: MonadIO m => TLSCtx c -> TLSSt a -> m (Either TLSError a) usingState ctx f = liftIO (takeMVar mvar) >>= \st -> liftIO $ onException (execAndStore st) (putMVar mvar st) 	where 		mvar = ctxState ctx@@ -165,17 +187,17 @@ 			putMVar mvar newst 			return a -usingState_ :: MonadIO m => TLSCtx -> TLSSt a -> m a+usingState_ :: MonadIO m => TLSCtx c -> TLSSt a -> m a usingState_ ctx f = do 	ret <- usingState ctx f 	case ret of 		Left err -> throwCore err 		Right r  -> return r -getStateRNG :: MonadIO m => TLSCtx -> Int -> m Bytes+getStateRNG :: MonadIO m => TLSCtx c -> Int -> m Bytes getStateRNG ctx n = usingState_ ctx (genTLSRandom n) -whileStatus :: MonadIO m => TLSCtx -> (TLSStatus -> Bool) -> m a -> m ()+whileStatus :: MonadIO m => TLSCtx c -> (TLSStatus -> Bool) -> m a -> m () whileStatus ctx p a = do 	b <- usingState_ ctx (p . stStatus <$> get) 	when b (a >> whileStatus ctx p a)@@ -184,12 +206,12 @@ errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _                           = Alert [(AlertLevel_Fatal, InternalError)] -setEOF :: MonadIO m => TLSCtx -> m ()+setEOF :: MonadIO m => TLSCtx c -> m () setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True -readExact :: MonadIO m => TLSCtx -> Int -> m Bytes+readExact :: MonadIO m => TLSCtx c -> Int -> m Bytes readExact ctx sz = do-	hdrbs <- liftIO $ B.hGet (ctxHandle ctx) sz+	hdrbs <- liftIO $ connectionRecv ctx sz 	when (B.length hdrbs < sz) $ do 		setEOF ctx 		if B.null hdrbs@@ -200,7 +222,7 @@ -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed-recvPacket :: MonadIO m => TLSCtx -> m (Either TLSError Packet)+recvPacket :: MonadIO m => TLSCtx c -> m (Either TLSError Packet) recvPacket ctx = do 	hdrbs <- readExact ctx 5 	case decodeHeader hdrbs of@@ -212,13 +234,13 @@ 	where recvLength header readlen = do 		content <- readExact ctx (fromIntegral readlen) 		liftIO $ (loggingIORecv $ ctxLogging ctx) header content-		pkt <- usingState ctx $ readPacket header (EncryptedData content)+		pkt <- usingState ctx $ readPacket $ rawToRecord header (fragmentCiphertext content) 		case pkt of 			Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p 			_       -> return () 		return pkt -recvPacketSuccess :: MonadIO m => TLSCtx -> m ()+recvPacketSuccess :: MonadIO m => TLSCtx c -> m () recvPacketSuccess ctx = do 	pkt <- recvPacket ctx 	case pkt of@@ -226,22 +248,34 @@ 		Right _  -> return ()  -- | Send one packet to the context-sendPacket :: MonadIO m => TLSCtx -> Packet -> m ()+sendPacket :: MonadIO m => TLSCtx c -> Packet -> m () sendPacket ctx pkt = do 	liftIO $ (loggingPacketSent $ ctxLogging ctx) (show pkt) 	dataToSend <- usingState_ ctx $ writePacket pkt 	liftIO $ (loggingIOSent $ ctxLogging ctx) dataToSend-	liftIO $ B.hPut (ctxHandle ctx) dataToSend+	liftIO $ connectionSend ctx dataToSend +-- | Create a new Client context with a configuration, a RNG, a generic connection and the connection operation.+clientWith :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> m (TLSCtx c)+clientWith params rng connection flushF sendF recvF =+	liftIO $ newCtxWith connection flushF sendF recvF params st+	where st = (newTLSState rng) { stClientContext = True }+ -- | Create a new Client context with a configuration, a RNG, and a Handle. -- It reconfigures the handle buffermode to noBuffering-client :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m TLSCtx+client :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle) client params rng handle = liftIO $ newCtx handle params st 	where st = (newTLSState rng) { stClientContext = True } +-- | Create a new Server context with a configuration, a RNG, a generic connection and the connection operation.+serverWith :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> m (TLSCtx c)+serverWith params rng connection flushF sendF recvF =+	liftIO $ newCtxWith connection flushF sendF recvF params st+	where st = (newTLSState rng) { stClientContext = False }+ -- | Create a new Server context with a configuration, a RNG, and a Handle. -- It reconfigures the handle buffermode to noBuffering-server :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m TLSCtx+server :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle) server params rng handle = liftIO $ newCtx handle params st 	where st = (newTLSState rng) { stClientContext = False } @@ -250,12 +284,12 @@ -- the session might not be resumable (for version < TLS1.2). -- -- this doesn't actually close the handle-bye :: MonadIO m => TLSCtx -> m ()+bye :: MonadIO m => TLSCtx c -> m () bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]  -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server.-handshakeClient :: MonadIO m => TLSCtx -> m ()+handshakeClient :: MonadIO m => TLSCtx c -> m () handshakeClient ctx = do 	-- Send ClientHello 	crand <- getStateRNG ctx 32 >>= return . ClientRandom@@ -283,7 +317,7 @@ 	{- FIXME not implemented yet -}  	sendPacket ctx ChangeCipherSpec-	liftIO $ hFlush $ ctxHandle ctx+	liftIO $ connectionFlush ctx  	-- Send Finished 	cf <- usingState_ ctx $ getHandshakeDigest True@@ -342,7 +376,7 @@ 		certificateRejected (CertificateRejectOther s) = 			throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) -handshakeServerWith :: MonadIO m => TLSCtx -> Handshake -> m ()+handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m () handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do 	-- Handle Client hello 	when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)@@ -350,17 +384,17 @@ 		throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) 	when (commonCiphers == []) $ 		throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)-	when (commonCompressions == []) $+	when (null commonCompressions) $ 		throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) 	usingState_ ctx $ modify (\st -> st-		{ stVersion = ver-		, stCipher  = Just usedCipher-		--, stCompression = Just usedCompression+		{ stVersion     = ver+		, stCipher      = Just usedCipher+		, stCompression = usedCompression 		})  	-- send Server Data until ServerHelloDone 	handshakeSendServerData-	liftIO $ hFlush $ ctxHandle ctx+	liftIO $ connectionFlush ctx  	-- Receive client info until client Finished. 	whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacketSuccess ctx)@@ -371,14 +405,14 @@ 	cf <- usingState_ ctx $ getHandshakeDigest False 	sendPacket ctx (Handshake [Finished cf]) -	liftIO $ hFlush $ ctxHandle ctx+	liftIO $ connectionFlush ctx 	return () 	where 		params             = ctxParams ctx 		commonCiphers      = intersect ciphers (map cipherID $ pCiphers params) 		usedCipher         = fromJust $ find (\c -> cipherID c == head commonCiphers) (pCiphers params)-		commonCompressions = intersect compressions (map compressionID $ pCompressions params)-		usedCompression    = fromJust $ find (\c -> compressionID c == head commonCompressions) (pCompressions params)+		commonCompressions = compressionIntersectID (pCompressions params) compressions+		usedCompression    = head commonCompressions 		srvCerts           = map fst $ pCertificates params 		privKeys           = map snd $ pCertificates params 		needKeyXchg        = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher@@ -423,7 +457,7 @@ handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello"  -- after receiving a client hello, we need to redo a handshake -}-handshakeServer :: MonadIO m => TLSCtx -> m ()+handshakeServer :: MonadIO m => TLSCtx c -> m () handshakeServer ctx = do 	pkts <- recvPacket ctx 	case pkts of@@ -432,7 +466,7 @@  -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegociation-handshake :: MonadIO m => TLSCtx -> m Bool+handshake :: MonadIO m => TLSCtx c -> m Bool handshake ctx = do 	cc <- usingState_ ctx (stClientContext <$> get) 	liftIO $ handleException $ if cc then handshakeClient ctx else handshakeServer ctx@@ -444,10 +478,10 @@  -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size-sendData :: MonadIO m => TLSCtx -> L.ByteString -> m ()+sendData :: MonadIO m => TLSCtx c -> L.ByteString -> m () sendData ctx dataToSend = do 	eofed <- ctxEOF ctx-	when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "sendData" (Just (ctxHandle ctx)) Nothing+	when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "sendData" Nothing Nothing 	mapM_ sendDataChunk (L.toChunks dataToSend) 		where sendDataChunk d = if B.length d > 16384 			then do@@ -459,10 +493,10 @@  -- | recvData get data out of Data packet, and automatically renegociate if -- a Handshake ClientHello is received-recvData :: MonadIO m => TLSCtx -> m L.ByteString+recvData :: MonadIO m => TLSCtx c -> m L.ByteString recvData ctx = do 	eofed <- ctxEOF ctx-	when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "recvData" (Just (ctxHandle ctx)) Nothing+	when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "recvData" Nothing Nothing 	pkt   <- recvPacket ctx 	case pkt of 		-- on server context receiving a client hello == renegociation@@ -478,5 +512,5 @@ 			setEOF ctx 			return L.empty 		Right (AppData x) -> return $ L.fromChunks [x]-		Right p           -> error ("error unexpected packet: p" ++ show p)+		Right p           -> error ("error unexpected packet: " ++ show p) 		Left err          -> error ("error received: " ++ show err)
Network/TLS/Crypto.hs view
@@ -1,23 +1,15 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ExistentialQuantification #-} module Network.TLS.Crypto-	( HashType(..)-	, HashCtx--	-- * incremental interface with algorithm type wrapping for genericity-	, initHash-	, updateHash-	, finalizeHash+	( HashCtx(..)+	, hashInit+	, hashUpdate+	, hashUpdateSSL+	, hashFinal -	-- * single pass lazy bytestring interface for each algorithm-	, hashMD5-	, hashSHA1-	-- * incremental interface for each algorithm-	, initMD5-	, updateMD5-	, finalizeMD5-	, initSHA1-	, updateSHA1-	, finalizeSHA1+	-- * constructor+	, hashMD5SHA1+	, hashSHA256  	-- * key exchange generic interface 	, PublicKey(..)@@ -27,6 +19,7 @@ 	, KxError(..) 	) where +import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString as B@@ -47,61 +40,58 @@ data KxError = RSAError RSA.Error 	deriving (Show) -data HashCtx =-	  SHA1 !SHA1.Ctx-	| MD5 !MD5.Ctx- data KeyXchg = 	  KxRSA RSA.PublicKey RSA.PrivateKey 	deriving (Show) -instance Show HashCtx where-	show (SHA1 _) = "sha1"-	show (MD5 _) = "md5"--data HashType = HashTypeSHA1 | HashTypeMD5--{- MD5 -}--initMD5 :: MD5.Ctx-initMD5 = MD5.init--updateMD5 :: MD5.Ctx -> ByteString -> MD5.Ctx-updateMD5 = MD5.update+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 -finalizeMD5 :: MD5.Ctx -> ByteString-finalizeMD5 = MD5.finalize+data HashCtx = forall h . HashCtxC h => HashCtx h -hashMD5 :: ByteString -> ByteString-hashMD5 = MD5.hash+instance Show HashCtx where+	show (HashCtx c) = hashCName c -{- SHA1 -}+{- MD5 & SHA1 joined -}+data HashMD5SHA1 = HashMD5SHA1 SHA1.Ctx MD5.Ctx -initSHA1 :: SHA1.Ctx-initSHA1 = SHA1.init+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] -updateSHA1 :: SHA1.Ctx -> ByteString -> SHA1.Ctx-updateSHA1 = SHA1.update+data HashSHA256 = HashSHA256 SHA256.Ctx -finalizeSHA1 :: SHA1.Ctx -> ByteString-finalizeSHA1 = SHA1.finalize+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 -hashSHA1 :: ByteString -> ByteString-hashSHA1 = SHA1.hash+-- functions to use the hidden class.+hashInit :: HashCtx -> HashCtx+hashInit   (HashCtx h)   = HashCtx $ hashCInit h -{- generic Hashing -}+hashUpdate :: HashCtx -> B.ByteString -> HashCtx+hashUpdate (HashCtx h) b = HashCtx $ hashCUpdate h b -initHash :: HashType -> HashCtx-initHash HashTypeSHA1 = SHA1 (initSHA1)-initHash HashTypeMD5  = MD5 (initMD5)+hashUpdateSSL :: HashCtx -> (B.ByteString,B.ByteString) -> HashCtx+hashUpdateSSL (HashCtx h) bs = HashCtx $ hashCUpdateSSL h bs -updateHash :: HashCtx -> B.ByteString -> HashCtx-updateHash (SHA1 ctx) = SHA1 . updateSHA1 ctx-updateHash (MD5 ctx)  = MD5 . updateMD5 ctx+hashFinal :: HashCtx -> B.ByteString+hashFinal  (HashCtx h)   = hashCFinal h -finalizeHash :: HashCtx -> B.ByteString-finalizeHash (SHA1 ctx) = finalizeSHA1 ctx-finalizeHash (MD5 ctx)  = finalizeMD5 ctx+-- real hash constructors+hashMD5SHA1, hashSHA256 :: HashCtx+hashMD5SHA1 = HashCtx (HashMD5SHA1 SHA1.init MD5.init)+hashSHA256  = HashCtx (HashSHA256 SHA256.init)  {- key exchange methods encrypt and decrypt for each supported algorithm -} generalizeRSAError :: Either RSA.Error a -> Either KxError a
Network/TLS/MAC.hs view
@@ -6,6 +6,7 @@ 	, hmac 	, prf_MD5 	, prf_SHA1+	, prf_SHA256 	, prf_MD5SHA1 	) where @@ -16,14 +17,16 @@ import Data.ByteString (ByteString) import Data.Bits (xor) -macSSL :: (ByteString -> ByteString) -> ByteString -> ByteString -> ByteString+type HMAC = ByteString -> ByteString -> ByteString++macSSL :: (ByteString -> ByteString) -> HMAC macSSL f secret msg = f $! B.concat [ secret, B.replicate padlen 0x5c, 			f $! B.concat [ secret, B.replicate padlen 0x36, msg ] ] 	where 		-- get the type of algorithm out of the digest length by using the hash fct. 		padlen = if (B.length $ f B.empty) == 16 then 48 else 40 -hmac :: (ByteString -> ByteString) -> Int -> ByteString -> ByteString -> ByteString+hmac :: (ByteString -> ByteString) -> Int -> HMAC hmac f bl secret msg = 	f $! B.append opad (f $! B.append ipad msg) 	where@@ -35,16 +38,16 @@ 			kt  = if B.length secret > fromIntegral bl then f secret else secret 			pad = B.replicate (fromIntegral bl - B.length kt) 0 -hmacMD5 :: ByteString -> ByteString -> ByteString+hmacMD5 :: HMAC hmacMD5 secret msg = hmac MD5.hash 64 secret msg -hmacSHA1 :: ByteString -> ByteString -> ByteString+hmacSHA1 :: HMAC hmacSHA1 secret msg = hmac SHA1.hash 64 secret msg -hmacSHA256 :: ByteString -> ByteString -> ByteString+hmacSHA256 :: HMAC hmacSHA256 secret msg = hmac SHA256.hash 64 secret msg -hmacIter :: (ByteString -> ByteString -> ByteString) -> ByteString -> ByteString -> ByteString -> Int -> [ByteString]+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@@ -66,3 +69,6 @@ 		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
@@ -63,6 +63,9 @@ 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@@ -105,11 +108,7 @@  - decode and encode headers  -} decodeHeader :: ByteString -> Either TLSError Header-decodeHeader = runGetErr "header" $ do-	ty  <- getHeaderType-	v   <- getVersion-	len <- getWord16-	return $ Header ty v len+decodeHeader = runGetErr "header" $ liftM3 Header getHeaderType getVersion getWord16  encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len)@@ -141,7 +140,7 @@  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)@@ -207,8 +206,7 @@  decodeCertificates :: Get Handshake decodeCertificates = do-	certslen <- getWord24-	certs <- getCerts certslen >>= return . map (decodeCertificate . L.fromChunks . (:[]))+	certs <- getWord24 >>= getCerts >>= return . map (decodeCertificate . L.fromChunks . (:[])) 	let (l, r) = partitionEithers certs 	if length l > 0 		then fail ("error certificate parsing: " ++ show l)@@ -219,14 +217,16 @@ 	opaque <- remaining >>= getBytes 	return $ Finished $ opaque -getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ]-getSignatureHashAlgorithm 0   = return []-getSignatureHashAlgorithm len = do+getSignatureHashAlgorithm :: Get (HashAlgorithm, SignatureAlgorithm)+getSignatureHashAlgorithm = do 	h <- fromJust . valToType <$> getWord8 	s <- fromJust . valToType <$> getWord8-	xs <- getSignatureHashAlgorithm (len - 2)-	return ((h, s) : xs)+	return (h,s) +getSignatureHashAlgorithms :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ]+getSignatureHashAlgorithms 0   = return []+getSignatureHashAlgorithms len = liftM2 (:) getSignatureHashAlgorithm (getSignatureHashAlgorithms (len-2))+ decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do 	certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8@@ -234,7 +234,7 @@ 	sigHashAlgs <- if cParamsVersion cp >= TLS12 		then do 			sighashlen <- getWord16-			Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen)+			Just <$> getSignatureHashAlgorithms (fromIntegral sighashlen) 		else return Nothing 	dNameLen <- getWord16 	when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"@@ -372,10 +372,8 @@ 		len -> Session . Just <$> getBytes len  putSession :: Session -> Put-putSession (Session session) =-	case session of-		Nothing -> putWord8 0-		Just s  -> putWord8 (fromIntegral $ B.length s) >> putBytes s+putSession (Session Nothing)  = putWord8 0+putSession (Session (Just s)) = putWord8 (fromIntegral $ B.length s) >> putBytes s  getCerts :: Int -> Get [Bytes] getCerts 0   = return []@@ -446,61 +444,72 @@ {-  - generate things for packet content  -}-generateMasterSecret_TLS, generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes-generateMasterSecret_TLS premasterSecret (ClientRandom c) (ServerRandom s) =-	prf_MD5SHA1 premasterSecret seed 48-	where-		seed = B.concat [ "master secret", c, s ]+type PRF = Bytes -> Bytes -> Int -> Bytes +generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = 	B.concat $ map (computeMD5) ["A","BB","CCC"] 	where-		computeMD5  label = hashMD5 $ B.concat [ premasterSecret, computeSHA1 label ]-		computeSHA1 label = hashSHA1 $ B.concat [ label, premasterSecret, c, s ]+		computeMD5  label = MD5.hash $ B.concat [ premasterSecret, computeSHA1 label ]+		computeSHA1 label = SHA1.hash $ B.concat [ label, premasterSecret, c, s ] +generateMasterSecret_TLS :: PRF -> Bytes -> ClientRandom -> ServerRandom -> Bytes+generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) =+	prf premasterSecret seed 48+	where+		seed = B.concat [ "master secret", c, s ]+ generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes-generateMasterSecret ver =-	if ver < TLS10 then generateMasterSecret_SSL else generateMasterSecret_TLS+generateMasterSecret SSL2  = generateMasterSecret_SSL+generateMasterSecret SSL3  = generateMasterSecret_SSL+generateMasterSecret TLS10 = generateMasterSecret_TLS prf_MD5SHA1+generateMasterSecret TLS11 = generateMasterSecret_TLS prf_MD5SHA1+generateMasterSecret TLS12 = generateMasterSecret_TLS prf_SHA256 -generateKeyBlock_TLS :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes-generateKeyBlock_TLS (ClientRandom c) (ServerRandom s) mastersecret kbsize =-	prf_MD5SHA1 mastersecret seed kbsize-	where-		seed = B.concat [ "key expansion", s, c ]+generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes+generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize =+	prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ]  generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = 	B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels 	where 		labels            = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ]-		computeMD5  label = hashMD5 $ B.concat [ mastersecret, computeSHA1 label ]-		computeSHA1 label = hashSHA1 $ B.concat [ label, mastersecret, s, c ]+		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 ver =-	if ver < TLS10 then generateKeyBlock_SSL else generateKeyBlock_TLS+generateKeyBlock SSL2  = generateKeyBlock_SSL+generateKeyBlock SSL3  = generateKeyBlock_SSL+generateKeyBlock TLS10 = generateKeyBlock_TLS prf_MD5SHA1+generateKeyBlock TLS11 = generateKeyBlock_TLS prf_MD5SHA1+generateKeyBlock TLS12 = generateKeyBlock_TLS prf_SHA256 -generateFinished_TLS :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes-generateFinished_TLS label mastersecret md5ctx sha1ctx =-	prf_MD5SHA1 mastersecret seed 12+generateFinished_TLS :: PRF -> Bytes -> Bytes -> HashCtx -> Bytes+generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 	where-		seed = B.concat [ label, finalizeHash md5ctx, finalizeHash sha1ctx ]+		seed = B.concat [ label, hashFinal hashctx ] -generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes-generateFinished_SSL sender mastersecret md5ctx sha1ctx =-	B.concat [md5hash, sha1hash]+generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> Bytes+generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] 	where-		md5hash  = hashMD5 $ B.concat [ mastersecret, pad2, md5left ]-		sha1hash = hashSHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ]-		md5left  = finalizeHash $ foldl updateHash md5ctx [ sender, mastersecret, pad1 ]-		sha1left = finalizeHash $ foldl updateHash sha1ctx [ sender, mastersecret, B.take 40 pad1 ]+		md5hash  = MD5.hash $ B.concat [ mastersecret, pad2, md5left ]+		sha1hash = SHA1.hash $ B.concat [ mastersecret, B.take 40 pad2, sha1left ]++		lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1)+		                     $ foldl hashUpdate hashctx [sender,mastersecret]+		(md5left,sha1left) = B.splitAt 16 lefthash 		pad2     = B.replicate 48 0x5c 		pad1     = B.replicate 48 0x36 -generateClientFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes-generateClientFinished ver =-	if ver < TLS10 then generateFinished_SSL "CLNT" else generateFinished_TLS "client finished"+generateClientFinished :: Version -> Bytes -> HashCtx -> Bytes+generateClientFinished ver+	| ver < TLS10 = generateFinished_SSL "CLNT"+	| ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "client finished"+	| otherwise   = generateFinished_TLS prf_SHA256 "client finished" -generateServerFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes-generateServerFinished ver =-	if ver < TLS10 then generateFinished_SSL "SRVR" else generateFinished_TLS "server 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"
Network/TLS/Receiving.hs view
@@ -23,9 +23,11 @@ import Network.TLS.Util import Network.TLS.Cap import Network.TLS.Struct+import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Cipher+import Network.TLS.Compression import Network.TLS.Crypto import Data.Certificate.X509 @@ -35,11 +37,11 @@ returnEither (Left err) = throwError err returnEither (Right a)  = return a -readPacket :: Header -> EncryptedData -> TLSSt Packet-readPacket hdr content = checkState hdr >> decryptContent hdr content >>= processPacket hdr+readPacket :: Record Ciphertext -> TLSSt Packet+readPacket record = checkState record >> decryptContent record >>= uncompressContent >>= processPacket -checkState :: Header -> TLSSt ()-checkState (Header pt _ _) =+checkState :: Record a -> TLSSt ()+checkState (Record pt _ _) = 		stStatus <$> get >>= \status -> unless (allowed pt status) $ throwError (err status) 	where 		err st = Error_Protocol ("unexpected message received: status=" ++ show st, True, UnexpectedMessage)@@ -54,23 +56,23 @@ 		allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True 		allowed _ _ = False -processPacket :: Header -> Bytes -> TLSSt Packet+processPacket :: Record Plaintext -> TLSSt Packet -processPacket (Header ProtocolType_AppData _ _) content = return $ AppData content+processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment -processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlerts content)+processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) -processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do+processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do 	e <- updateStatusCC False 	when (isJust e) $ throwError (fromJust "" e) -	returnEither $ decodeChangeCipherSpec content+	returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment 	switchRxEncryption 	isClientContext >>= \cc -> when (not cc) setKeyBlock 	return ChangeCipherSpec -processPacket (Header ProtocolType_Handshake ver _) dcontent = do-	handshakes <- returnEither (decodeHandshakes dcontent)+processPacket (Record ProtocolType_Handshake ver fragment) = do+	handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment) 	hss <- forM handshakes $ \(ty, content) -> do 		hs <- processHandshake ver ty content 		when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content@@ -155,57 +157,57 @@ 	cc <- stClientContext <$> get 	expected <- getHandshakeDigest (not cc) 	when (expected /= fdata) $ do-		throwError $ Error_Protocol( "bad record mac", True, BadRecordMac)+		throwError $ Error_Protocol("bad record mac", True, BadRecordMac) 	updateVerifiedData False fdata 	return () -decryptContent :: Header -> EncryptedData -> TLSSt ByteString-decryptContent hdr e@(EncryptedData b) = do+-- just `decompress' by returning the data for now till we have compression implemented+uncompressContent :: Record Compressed -> TLSSt (Record Plaintext)+uncompressContent record = onRecordFragment record $ fragmentUncompress $ \bytes ->+	withCompression $ compressionInflate bytes++decryptContent :: Record Ciphertext -> TLSSt (Record Compressed)+decryptContent record = onRecordFragment record $ fragmentUncipher $ \e -> do 	st <- get 	if stRxEncrypted st-		then decryptData e >>= getCipherData hdr-		else return b+		then decryptData e >>= getCipherData record+		else return e -getCipherData :: Header -> CipherData -> TLSSt ByteString-getCipherData hdr cdata = do+getCipherData :: Record a -> CipherData -> TLSSt ByteString+getCipherData (Record pt ver _) cdata = do 	-- check if the MAC is valid. 	macValid <- case cipherDataMAC cdata of 		Nothing     -> return True 		Just digest -> do-			let (Header pt ver _) = hdr 			let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) 			expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata-			if expected_digest == digest-				then return True-				else return False+			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-			ver <- stVersion <$> get+			cver <- stVersion <$> get 			let b = B.length pad - 1-			if ver < TLS10-				then return True-				else return $ maybe True (const False) $ B.find (/= fromIntegral b) pad+			return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) -	unless (and $! [ macValid, paddingValid ]) $ do+	unless (macValid &&! paddingValid) $ do 		throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)  	return $ cipherDataContent cdata -decryptData :: EncryptedData -> TLSSt CipherData-decryptData (EncryptedData econtent) = do+decryptData :: Bytes -> TLSSt CipherData+decryptData econtent = do 	st <- get -	let cipher       = fromJust "cipher" $ stCipher st-	let cst          = fromJust "rx crypt state" $ stRxCryptState st-	let padding_size = fromIntegral $ cipherPaddingSize cipher-	let digestSize   = fromIntegral $ cipherDigestSize cipher-	let writekey     = cstKey cst+	let cipher     = fromJust "cipher" $ stCipher st+	let bulk       = cipherBulk cipher+	let cst        = fromJust "rx crypt state" $ stRxCryptState st+	let digestSize = hashSize $ cipherHash cipher+	let writekey   = cstKey cst -	case cipherF cipher of-		CipherNoneF -> do+	case bulkF bulk of+		BulkNoneF -> do 			let contentlen = B.length econtent - digestSize 			case partition3 econtent (contentlen, digestSize, 0) of 				Nothing                ->@@ -216,13 +218,13 @@ 						, cipherDataMAC     = Just mac 						, cipherDataPadding = Nothing 						}-		CipherBlockF _ decryptF -> do+		BulkBlockF _ decryptF -> do 			{- update IV -} 			let (iv, econtent') = 				if hasExplicitBlockIV $ stVersion st-					then B.splitAt (fromIntegral $ cipherIVSize cipher) econtent+					then B.splitAt (bulkIVSize bulk) econtent 					else (cstIV cst, econtent)-			let newiv = fromJust "new iv" $ takelast padding_size econtent'+			let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent' 			put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }  			let content' = decryptF writekey iv econtent'@@ -234,7 +236,7 @@ 				, cipherDataMAC     = Just mac 				, cipherDataPadding = Just padding 				}-		CipherStreamF initF _ decryptF -> do+		BulkStreamF initF _ decryptF -> do 			let iv = cstIV cst 			let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent 			{- update Ctx -}
+ Network/TLS/Record.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE EmptyDataDecls #-}+-- |+-- Module      : Network.TLS.Record+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- The Record Protocol takes messages to be transmitted, fragments the+-- data into manageable blocks, optionally compresses the data, applies+-- a MAC, encrypts, and transmits the result.  Received data is+-- decrypted, verified, decompressed, reassembled, and then delivered to+-- higher-level clients.+--+module Network.TLS.Record+	( Header(..)+	, ProtocolType(..)+	, packetType+	-- * TLS Records+	, Record(..)+	-- * TLS Record fragment and constructors+	, Fragment+	, fragmentPlaintext+	, fragmentCiphertext+	, fragmentGetBytes+	, Plaintext+	, Compressed+	, Ciphertext+	-- * manipulate record+	, onRecordFragment+	, fragmentCompress+	, fragmentCipher+	, fragmentUncipher+	, fragmentUncompress+	-- * serialize record+	, rawToRecord+	, recordToRaw+	, recordToHeader+	) where++import Network.TLS.Struct+import Network.TLS.State+import qualified Data.ByteString as B+import Control.Applicative ((<$>))++-- | Represent a TLS record.+data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)++newtype Fragment a = Fragment Bytes deriving (Show,Eq)++data Plaintext+data Compressed+data Ciphertext++fragmentPlaintext :: Bytes -> Fragment Plaintext+fragmentPlaintext bytes = Fragment bytes++fragmentCiphertext :: Bytes -> Fragment Ciphertext+fragmentCiphertext bytes = Fragment bytes++fragmentGetBytes :: Fragment a -> Bytes+fragmentGetBytes (Fragment bytes) = bytes++onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b)+onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag++fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b)+fragmentMap f (Fragment b) = Fragment <$> f b++-- | turn a plaintext record into a compressed record using the compression function supplied+fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed)+fragmentCompress f = fragmentMap f++-- | turn a compressed record into a ciphertext record using the cipher function supplied+fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext)+fragmentCipher f = fragmentMap f++-- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied+fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed)+fragmentUncipher f = fragmentMap f++-- | turn a compressed fragment into a plaintext fragment using the decompression function supplied+fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext)+fragmentUncompress f = fragmentMap f++-- | turn a record into an header and bytes+recordToRaw :: Record a -> (Header, Bytes)+recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes)++-- | turn a header and a fragment into a record+rawToRecord :: Header -> Fragment a -> Record a+rawToRecord (Header pt ver _) fragment = Record pt ver fragment++-- | turn a record into a header+recordToHeader :: Record a -> Header+recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes)
Network/TLS/Sending.hs view
@@ -12,6 +12,7 @@ 	writePacket 	) where +import Control.Applicative ((<$>)) import Control.Monad.State  import Data.ByteString (ByteString)@@ -21,57 +22,63 @@ import Network.TLS.Cap import Network.TLS.Wire import Network.TLS.Struct+import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Cipher+import Network.TLS.Compression import Network.TLS.Crypto  {-  - 'makePacketData' create a Header and a content bytestring related to a packet  - this doesn't change any state  -}-makePacketData :: Packet -> TLSSt (Header, ByteString)-makePacketData pkt = do-	ver <- get >>= return . stVersion+makeRecord :: Packet -> TLSSt (Record Plaintext)+makeRecord pkt = do+	ver <- stVersion <$> get 	content <- writePacketContent pkt-	let hdr = Header (packetType pkt) ver (fromIntegral $ B.length content)-	return (hdr, content)+	return $ Record (packetType pkt) ver (fragmentPlaintext content)  {-  - Handshake data need to update a digest  -}-processPacketData :: (Header, ByteString) -> TLSSt (Header, ByteString)-processPacketData dat@(Header ty _ _, content) = do-	when (ty == ProtocolType_Handshake) (updateHandshakeDigest content)-	return dat+processRecord :: Record Plaintext -> TLSSt (Record Plaintext)+processRecord record@(Record ty _ fragment) = do+	when (ty == ProtocolType_Handshake) (updateHandshakeDigest $ fragmentGetBytes fragment)+	return record +compressRecord :: Record Plaintext -> TLSSt (Record Compressed)+compressRecord record =+	onRecordFragment record $ fragmentCompress $ \bytes -> do+		withCompression $ compressionDeflate bytes+ {-  - when Tx Encrypted is set, we pass the data through encryptContent, otherwise  - we just return the packet  -}-encryptPacketData :: (Header, ByteString) -> TLSSt (Header, ByteString)-encryptPacketData dat = do+encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext)+encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do 	st <- get 	if stTxEncrypted st-		then encryptContent dat-		else return dat+		then encryptContent record bytes+		else return bytes  {-  - 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  -}-postprocessPacketData :: (Header, ByteString) -> TLSSt (Header, ByteString)-postprocessPacketData dat@(Header ProtocolType_ChangeCipherSpec _ _, _) =-	switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return dat--postprocessPacketData dat = return dat+postprocessRecord :: Record Ciphertext -> TLSSt (Record Ciphertext)+postprocessRecord record@(Record ProtocolType_ChangeCipherSpec _ _) =+	switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return record+postprocessRecord record = return record  {-  - marshall packet data  -}-encodePacket :: (Header, ByteString) -> TLSSt ByteString-encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]+encodeRecord :: Record Ciphertext -> TLSSt ByteString+encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]+	where (hdr, content) = recordToRaw record  {-  - just update TLS state machine@@ -92,8 +99,9 @@  - and updating state on the go  -} writePacket :: Packet -> TLSSt ByteString-writePacket pkt = preProcessPacket pkt >> makePacketData pkt >>= processPacketData >>=-                  encryptPacketData >>= postprocessPacketData >>= encodePacket+writePacket pkt = do+	preProcessPacket pkt+	makeRecord pkt >>= processRecord >>= compressRecord >>= encryptRecord >>= postprocessRecord >>= encodeRecord  {------------------------------------------------------------------------------} {- SENDING Helpers                                                            -}@@ -110,46 +118,46 @@ 		Left err               -> fail ("rsa encrypt failed: " ++ show err) 		Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent -encryptContent :: (Header, ByteString) -> TLSSt (Header, ByteString)-encryptContent (hdr@(Header pt ver _), content) = do-	digest <- makeDigest True hdr content-	encrypted_msg <- encryptData $ B.concat [content, digest]-	let hdrnew = Header pt ver (fromIntegral $ B.length encrypted_msg)-	return (hdrnew, encrypted_msg)+encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString+encryptContent record content = do+	digest <- makeDigest True (recordToHeader record) content+	encryptData $ B.concat [content, digest]  encryptData :: ByteString -> TLSSt ByteString encryptData content = do 	st <- get  	let cipher = fromJust "cipher" $ stCipher st+	let bulk = cipherBulk cipher 	let cst = fromJust "tx crypt state" $ stTxCryptState st-	let padding_size = fromIntegral $ cipherPaddingSize cipher -	let msg_len = B.length content-	let padding = if padding_size > 0-		then-			let padbyte = padding_size - (msg_len `mod` padding_size) in-			let padbyte' = if padbyte == 0 then padding_size else padbyte in-			B.replicate padbyte' (fromIntegral (padbyte' - 1))-		else-			B.empty 	let writekey = cstKey cst -	case cipherF cipher of-		CipherNoneF -> return content-		CipherBlockF encrypt _ -> do+	case bulkF bulk of+		BulkNoneF -> return content+		BulkBlockF encrypt _ -> do+			let blockSize = fromIntegral $ bulkBlockSize bulk+			let msg_len = B.length content+			let padding = if blockSize > 0+				then+					let padbyte = blockSize - (msg_len `mod` blockSize) in+					let padbyte' = if padbyte == 0 then blockSize else padbyte in+					B.replicate padbyte' (fromIntegral (padbyte' - 1))+				else+					B.empty+ 			-- before TLS 1.1, the block cipher IV is made of the residual of the previous block. 			iv <- if hasExplicitBlockIV $ stVersion st-				then genTLSRandom (fromIntegral $ cipherIVSize cipher)+				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 (fromIntegral $ cipherIVSize cipher) e+					let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e 					put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } 					return e-		CipherStreamF initF encryptF _ -> do+		BulkStreamF initF encryptF _ -> do 			let iv = cstIV cst 			let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content 			put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }
Network/TLS/State.hs view
@@ -21,6 +21,7 @@ 	, newTLSState 	, genTLSRandom 	, withTLSRNG+	, withCompression 	, assert -- FIXME move somewhere else (Internal.hs ?) 	, updateStatusHs 	, updateStatusCC@@ -58,6 +59,7 @@ import Network.TLS.Packet import Network.TLS.Crypto import Network.TLS.Cipher+import Network.TLS.Compression import Network.TLS.MAC import qualified Data.ByteString as B import Control.Applicative ((<$>))@@ -109,7 +111,7 @@ 	, hstMasterSecret    :: !(Maybe Bytes) 	, hstRSAPublicKey    :: !(Maybe PublicKey) 	, hstRSAPrivateKey   :: !(Maybe PrivateKey)-	, hstHandshakeDigest :: Maybe (HashCtx, HashCtx) -- FIXME could be only 1 hash in tls12+	, hstHandshakeDigest :: !HashCtx 	} deriving (Show)  data StateRNG = forall g . CryptoRandomGen g => StateRNG g@@ -129,6 +131,7 @@ 	, stTxMacState          :: !(Maybe TLSMacState) 	, stRxMacState          :: !(Maybe TLSMacState) 	, stCipher              :: Maybe Cipher+	, stCompression         :: Compression 	, stRandomGen           :: StateRNG 	, stSecureRenegotiation :: Bool  -- RFC 5746 	, stClientVerifiedData  :: Bytes -- RFC 5746@@ -161,6 +164,7 @@ 	, stTxMacState          = Nothing 	, stRxMacState          = Nothing 	, stCipher              = Nothing+	, stCompression         = nullCompression 	, stRandomGen           = StateRNG rng 	, stSecureRenegotiation = False 	, stClientVerifiedData  = B.empty@@ -172,6 +176,13 @@ 	Left err        -> Left err 	Right (a, rng') -> Right (a, StateRNG rng') +withCompression :: (Compression -> (Compression, a)) -> TLSSt a+withCompression f = do+	compression <- stCompression <$> get+	let (nc, a) = f compression+	modify (\st -> st { stCompression = nc })+	return a+ genTLSRandom :: (MonadState TLSState m, MonadError TLSError m) => Int -> m Bytes genTLSRandom n = do 	st <- get@@ -186,12 +197,12 @@ 	let cst = fromJust "crypt state" $ if w then stTxCryptState st else stRxCryptState st 	let ms = fromJust "mac state" $ if w then stTxMacState st else stRxMacState st 	let cipher = fromJust "cipher" $ stCipher st-	let machash = cipherMACHash cipher+	let hashf = hashF $ cipherHash cipher  	let (macF, msg) = 		if ver < TLS10-			then (macSSL machash, B.concat [ encodeWord64 $ msSequence ms, encodeHeaderNoVer hdr, content ])-			else (hmac machash 64, B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ])+			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 }@@ -314,10 +325,12 @@  	let cc = stClientContext st 	let cipher = fromJust "cipher" $ stCipher st-	let keyblockSize = fromIntegral $ cipherKeyBlockSize cipher-	let digestSize   = fromIntegral $ cipherDigestSize cipher-	let keySize      = fromIntegral $ cipherKeySize cipher-	let ivSize       = fromIntegral $ cipherIVSize cipher+	let keyblockSize = cipherKeyBlockSize cipher++	let bulk = cipherBulk cipher+	let digestSize   = hashSize $ cipherHash cipher+	let keySize      = bulkKeySize bulk+	let ivSize       = bulkIVSize bulk 	let kb = generateKeyBlock (stVersion st) (hstClientRandom hst) 	                          (fromJust "server random" $ hstServerRandom hst) 	                          (fromJust "master secret" $ hstMasterSecret hst) keyblockSize@@ -364,23 +377,24 @@ isClientContext = get >>= return . stClientContext  -- create a new empty handshake state-newEmptyHandshake :: Version -> ClientRandom -> TLSHandshakeState-newEmptyHandshake ver crand = TLSHandshakeState+newEmptyHandshake :: Version -> ClientRandom -> HashCtx -> TLSHandshakeState+newEmptyHandshake ver crand digestInit = TLSHandshakeState 	{ hstClientVersion   = ver 	, hstClientRandom    = crand 	, hstServerRandom    = Nothing 	, hstMasterSecret    = Nothing 	, hstRSAPublicKey    = Nothing 	, hstRSAPrivateKey   = Nothing-	, hstHandshakeDigest = Nothing+	, hstHandshakeDigest = digestInit 	}  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 })+		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) ]@@ -391,14 +405,8 @@ 	modify (\st -> st { stHandshake = f <$> stHandshake st })  updateHandshakeDigest :: MonadState TLSState m => Bytes -> m ()-updateHandshakeDigest content = updateHandshake "update digest" (\hs ->-	let (c1, c2) = case hstHandshakeDigest hs of-		Nothing                -> (initHash HashTypeSHA1, initHash HashTypeMD5)-		Just (sha1ctx, md5ctx) -> (sha1ctx, md5ctx) in-	let nc1 = updateHash c1 content in-	let nc2 = updateHash c2 content in-	hs { hstHandshakeDigest = Just (nc1, nc2) }-	)+updateHandshakeDigest content = updateHandshake "update digest" $ \hs ->+	hs { hstHandshakeDigest = hashUpdate (hstHandshakeDigest hs) content }  updateHandshakeDigestSplitted :: MonadState TLSState m => HandshakeType -> Bytes -> m () updateHandshakeDigestSplitted ty bytes = updateHandshakeDigest $ B.concat [hdr, bytes]@@ -409,9 +417,9 @@ getHandshakeDigest client = do 	st <- get 	let hst = fromJust "handshake" $ stHandshake st-	let (sha1ctx, md5ctx) = fromJust "handshake digest" $ hstHandshakeDigest hst-	let msecret           = fromJust "master secret" $ hstMasterSecret hst-	return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret md5ctx sha1ctx+	let hashctx = hstHandshakeDigest hst+	let msecret = fromJust "master secret" $ hstMasterSecret hst+	return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret hashctx  endHandshake :: MonadState TLSState m => m () endHandshake = modify (\st -> st { stHandshake = Nothing })
Network/TLS/Struct.hs view
@@ -16,7 +16,6 @@ 	, CipherType(..) 	, CipherData(..) 	, Extension-	, EncryptedData(..) 	, CertificateType(..) 	, HashAlgorithm(..) 	, SignatureAlgorithm(..)@@ -48,7 +47,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B (length) import Data.Word-import Data.Certificate.X509+import Data.Certificate.X509 (X509) import Data.Typeable import Control.Monad.Error (Error(..)) import Control.Exception (Exception(..))@@ -137,7 +136,7 @@ 	| AppData ByteString 	deriving (Show,Eq) -data Header = Header ProtocolType Version Word16 deriving (Show, Eq)+data Header = Header ProtocolType Version Word16 deriving (Show,Eq)  newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq) newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq)@@ -156,9 +155,6 @@  clientRandom :: Bytes -> Maybe ClientRandom clientRandom l = constrRandom32 ClientRandom l--newtype EncryptedData = EncryptedData ByteString-	deriving (Show)  data AlertLevel = 	  AlertLevel_Warning
Network/TLS/Util.hs view
@@ -4,8 +4,12 @@ 	, partition3 	, partition6 	, fromJust+	, and'+	, (&&!)+	, bytesEq 	) where +import Data.List (foldl') import Network.TLS.Struct (Bytes) import qualified Data.ByteString as B @@ -41,3 +45,20 @@ fromJust :: String -> Maybe a -> a fromJust what Nothing  = error ("fromJust " ++ what ++ ": Nothing") -- yuck fromJust _    (Just x) = x++-- | This is a strict version of and+and' :: [Bool] -> Bool+and' l = foldl' (&&!) True l++-- | This is a strict version of &&.+(&&!) :: Bool -> Bool -> Bool+True  &&! True  = True+True  &&! False = False+False &&! True  = False+False &&! False = False++-- | verify that 2 bytestrings are equals.+-- it's a non lazy version, that will compare every bytes.+-- arguments need to be of same length+bytesEq :: Bytes -> Bytes -> Bool+bytesEq b1 = and' . B.zipWith (==) b1
Network/TLS/Wire.hs view
@@ -40,6 +40,7 @@ import Data.Bits import Network.TLS.Struct +runGet :: String -> Get a -> Bytes -> Either String a runGet lbl f = G.runGet (label lbl f)  getWords8 :: Get [Word8]
− README 
@@ -1,7 +0,0 @@-The hs-tls project aims to reimplement the full TLS protocol (formely known as SSL) in haskell.-The focus of the projects is to provide a safer implementation than the ones existing,-through more purity, more type-checking, and more units tests.--While the focus is to make it safer than other implementations, this current-implementation is *not* to be considered secure, since it doesn't fully-implement everything necessary (full certificate checking, protocol requirements, etc)
+ README.md view
@@ -0,0 +1,25 @@+haskell TLS+===========++This library provide native Haskell TLS and SSL protocol implementation for server and client.++Description+-----------++This provides a high-level implementation of a sensitive security protocol,+eliminating a common set of security issues through the use of the advanced+type system, high level constructions and common Haskell features.++Only core protocol available here, have a look at the tls-extra package for+default ciphers, compressions and certificates functions.++Features+--------++* tiny code base (more than 20 times smaller than openSSL, and 10 times smaller than gnuTLS)+* permissive license: BSD3.+* supported versions: SSL3, TLS1.0, TLS1.1, TLS1.2.+* key exchange supported: only RSA.+* bulk algorithm supported: any stream or block ciphers.+* supported extensions: secure renegociation+
TODO view
@@ -4,17 +4,9 @@ - add Client Certificates - process session as they should - put 4 bytes of time in client/server random-- implement compression - proper separation for key exchange algorithm (hardcoded to RSA at the moment in differents place) - implements different key exchange algorithm--tls v1.2:--- implement finish digest generation with hmac256-- implement finish digest generation with client/server negociated algorithm-- proper version dispatch in marshalling packets-- properly separate different version of the protocol-- implement AEAD+- implement AEAD bulk algorithm (TLS1.2)  code cleanup: @@ -28,7 +20,6 @@  misc: -- stunnel: actually make it works like stunnel instead of hardcoding the data received/sent - investigate an iteratee/enumerator interface - portability - implement more ciphers
tls.cabal view
@@ -1,5 +1,5 @@ Name:                tls-Version:             0.7.2+Version:             0.8.0 Description:    Native Haskell TLS and SSL protocol implementation for server and client.    .@@ -7,7 +7,7 @@    eliminating a common set of security issues through the use of the advanced    type system, high level constructions and common Haskell features.    .-   Currently implement the SSL3.0, TLS1.0 and TLS1.1 protocol,+   Currently implement the SSL3.0, TLS1.0, TLS1.1 and TLS1.2 protocol,    with only RSA supported for Key Exchange.    .    Only core protocol available here, have a look at the@@ -24,7 +24,7 @@ stability:           experimental Cabal-Version:       >=1.6 Homepage:            http://github.com/vincenthz/hs-tls-data-files:          README, TODO+data-files:          README.md, TODO  Flag test   Description:       Build unit test@@ -42,7 +42,7 @@                    , bytestring                    , crypto-api >= 0.5                    , cryptocipher >= 0.2.5-                   , certificate >= 0.9 && < 1.0+                   , certificate >= 0.9.3 && < 1.0   Exposed-modules:   Network.TLS                      Network.TLS.Cipher                      Network.TLS.Compression@@ -53,6 +53,7 @@                      Network.TLS.Core                      Network.TLS.Crypto                      Network.TLS.Packet+                     Network.TLS.Record                      Network.TLS.State                      Network.TLS.Sending                      Network.TLS.Receiving