move initiate into handshake in core.

Network/TLS/Client.hs

@@ -1,117 +1,9 @@
--- |
--- Module      : Network.TLS.Client
--- License     : BSD-style
--- Maintainer  : Vincent Hanquez <vincent@snarc.org>
--- Stability   : experimental
--- Portability : unknown
---
--- the Client module contains the necessary calls to create a connecting TLS socket
--- aka. a client socket.
---
-module Network.TLS.Client
-	( client
-	-- * API, warning probably subject to change
-	, initiate
-	, recvData
-	) where
+module Network.TLS.Client (recvData) where
 
-import Data.Maybe
 import Control.Monad.Trans
-import Control.Monad.State
-import Network.TLS.Cipher
-import Network.TLS.Compression
 import Network.TLS.Struct
-import Network.TLS.State
 import Network.TLS.Core
-import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
-import System.IO (hFlush)
-import Data.List (find)
-
-processServerInfo :: MonadIO m => TLSCtx -> Packet -> m ()
-processServerInfo ctx (Handshake (ServerHello ver _ _ cipher _ _)) = do
-	let ciphers     = pCiphers $ getParams ctx
-	let allowedvers = pAllowedVersions $ getParams ctx
-
-	case find ((==) ver) allowedvers of
-		Nothing -> error ("received version which is not allowed: " ++ show ver)
-		Just _  -> usingState_ ctx $ setVersion ver
-	case find ((==) cipher . cipherID) ciphers of
-		Nothing -> error "no cipher in common with the server"
-		Just c  -> usingState_ ctx $ setCipher c
-
-processServerInfo _ (Handshake (CertRequest _ _ _)) = do
-	return ()
-	--modify (\sc -> sc { scCertRequested = True })
-
-processServerInfo ctx (Handshake (Certificates certs)) = do
-	let cb = onCertificatesRecv $ getParams ctx
-	valid <- liftIO $ cb certs
-	unless valid $ error "certificates received deemed invalid by user"
-
-processServerInfo _ _ = return ()
-
-recvServerInfo :: MonadIO m => TLSCtx -> m ()
-recvServerInfo ctx = do
-	whileStatus ctx (/= (StatusHandshake HsStatusServerHelloDone)) $ do
-		pkts <- recvPacket ctx
-		case pkts of
-			Left err -> error ("error received: " ++ show err)
-			Right l  -> mapM_ (processServerInfo ctx) l
-
-connectSendClientHello :: MonadIO m => TLSCtx -> m ()
-connectSendClientHello ctx  = do
-	crand <- getStateRNG ctx 32 >>= return . fromJust . clientRandom
-	sendPacket ctx $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) (map compressionID compressions) Nothing)
-	where
-		params       = getParams ctx
-		ver          = pConnectVersion params
-		ciphers      = pCiphers params
-		compressions = pCompressions params
-
-connectSendClientCertificate :: MonadIO m => TLSCtx -> m ()
-connectSendClientCertificate ctx = do
-	certRequested <- return False -- scCertRequested <$> get
-	when certRequested $ do
-		let clientCerts = map fst $ pCertificates $ getParams ctx
-		sendPacket ctx $ Handshake (Certificates clientCerts)
-
-connectSendClientKeyXchg :: MonadIO m => TLSCtx -> m ()
-connectSendClientKeyXchg ctx = do
-	prerand <- getStateRNG ctx 46 >>= return . ClientKeyData
-	let ver = pConnectVersion $ getParams ctx
-	sendPacket ctx $ Handshake (ClientKeyXchg ver prerand)
-
-connectSendFinish :: MonadIO m => TLSCtx -> m ()
-connectSendFinish ctx = do
-	cf <- usingState_ ctx $ getHandshakeDigest True
-	sendPacket ctx (Handshake $ Finished $ B.unpack cf)
-
-{- | initiate a new TLS connection through a handshake on a handle. -}
-initiate :: MonadIO m => TLSCtx -> m ()
-initiate handle = do
-	connectSendClientHello handle
-	recvServerInfo handle
-	connectSendClientCertificate handle
-
-	connectSendClientKeyXchg handle
-
-	{- maybe send certificateVerify -}
-	{- FIXME not implemented yet -}
-
-	sendPacket handle (ChangeCipherSpec)
-	liftIO $ hFlush $ getHandle handle
-
-	{- send Finished -}
-	connectSendFinish handle
-	
-	{- receive changeCipherSpec -}
-	_ <- recvPacket handle
-
-	{- receive Finished -}
-	_ <- recvPacket handle
-
-	return ()
 
 {- | recvData get data out of Data packet, and automatically renegociate if
  - a Handshake ClientHello is received -}
@@ -120,6 +12,6 @@ recvData handle = do
 	pkt <- recvPacket handle
 	case pkt of
 		Right [AppData x] -> return $ L.fromChunks [x]
-		Right [Handshake HelloRequest] -> initiate handle >> recvData handle
+		Right [Handshake HelloRequest] -> handshake handle >> recvData handle
 		Left err          -> error ("error received: " ++ show err)
 		_                 -> error "unexpected item"

Network/TLS/Core.hs

@@ -6,21 +6,26 @@
 -- Portability : unknown
 --
 module Network.TLS.Core
-	( TLSParams(..)
+	(
+	-- ^ Context configuration
+	  TLSParams(..)
 	, defaultParams
+	-- ^ Context object
 	, TLSCtx
-	, newCtx
 	, getParams
 	, getHandle
+	-- hide
 	, usingState
 	, usingState_
 	, getStateRNG
 	, whileStatus
+	-- api
 	, sendPacket
 	, recvPacket
 	, client
 	, server
 	, bye
+	, handshake
 	, sendData
 	) where
 
@@ -34,14 +39,14 @@ import Network.TLS.Sending
 import Network.TLS.Receiving
 import Network.TLS.SRandom
 import Data.Certificate.X509
-import Data.List (intercalate)
+import Data.List (intercalate, find)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
 import Control.Applicative ((<$>))
 import Control.Concurrent.MVar
 import Control.Monad.State
-import System.IO (Handle, hSetBuffering, BufferMode(..))
+import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush)
 
 data TLSParams = TLSParams
 	{ pConnectVersion    :: Version             -- ^ version to use on client connection.
@@ -150,6 +155,81 @@ getHandle = ctxHandle
 bye :: MonadIO m => TLSCtx -> m ()
 bye ctx = sendPacket ctx $ Alert (AlertLevel_Warning, CloseNotify)
 
+{- | handshake a new TLS connection through a handshake on a handle. -}
+handshakeClient :: MonadIO m => TLSCtx -> m ()
+handshakeClient ctx = do
+	-- Send ClientHello
+	crand <- getStateRNG ctx 32 >>= return . ClientRandom
+	sendPacket ctx $ Handshake $ ClientHello ver crand
+	                                         (Session Nothing)
+	                                         (map cipherID ciphers)
+	                                         (map compressionID compressions)
+	                                         Nothing
+
+	-- Receive Server information until ServerHelloDone
+	whileStatus ctx (/= (StatusHandshake HsStatusServerHelloDone)) $ do
+		pkts <- recvPacket ctx
+		case pkts of
+			Left err -> error ("error received: " ++ show err)
+			Right l  -> mapM_ processServerInfo l
+
+	-- Send Certificate if requested. XXX disabled for now.
+	certRequested <- return False
+	when certRequested (sendPacket ctx $ Handshake (Certificates clientCerts))
+
+	-- Send ClientKeyXchg
+	prerand <- getStateRNG ctx 46 >>= return . ClientKeyData
+	sendPacket ctx $ Handshake (ClientKeyXchg ver prerand)
+
+	{- maybe send certificateVerify -}
+	{- FIXME not implemented yet -}
+
+	sendPacket ctx ChangeCipherSpec
+	liftIO $ hFlush $ getHandle ctx
+
+	-- Send Finished
+	cf <- usingState_ ctx $ getHandshakeDigest True
+	sendPacket ctx (Handshake $ Finished $ B.unpack cf)
+
+	-- receive changeCipherSpec & Finished
+	recvPacket ctx >> recvPacket ctx >> return ()
+
+	where
+		params       = getParams ctx
+		ver          = pConnectVersion params
+		allowedvers  = pAllowedVersions params
+		ciphers      = pCiphers params
+		compressions = pCompressions params
+		clientCerts  = map fst $ pCertificates params
+
+		processServerInfo (Handshake (ServerHello rver _ _ cipher _ _)) = do
+			case find ((==) rver) allowedvers of
+				Nothing -> error ("received version which is not allowed: " ++ show ver)
+				Just _  -> usingState_ ctx $ setVersion ver
+			case find ((==) cipher . cipherID) ciphers of
+				Nothing -> error "no cipher in common with the server"
+				Just c  -> usingState_ ctx $ setCipher c
+
+		processServerInfo (Handshake (CertRequest _ _ _)) = do
+			return ()
+			--modify (\sc -> sc { scCertRequested = True })
+
+		processServerInfo (Handshake (Certificates certs)) = do
+			let cb = onCertificatesRecv $ getParams ctx
+			valid <- liftIO $ cb certs
+			unless valid $ error "certificates received deemed invalid by user"
+
+		processServerInfo _ = return ()
+
+{-| 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 ()
+handshake ctx = do
+	cc <- usingState_ ctx (stClientContext <$> get)
+	if cc
+		then handshakeClient ctx
+		else undefined
+
 {- | sendData sends a bunch of data -}
 sendData :: MonadIO m => TLSCtx -> L.ByteString -> m ()
 sendData ctx dataToSend = mapM_ sendDataChunk (L.toChunks dataToSend)
@@ -161,4 +241,3 @@ sendData ctx dataToSend = mapM_ sendDataChunk (L.toChunks dataToSend)
 				sendDataChunk remain
 			else
 				sendPacket ctx $ AppData d
-

Network/TLS/Server.hs

@@ -88,8 +88,8 @@ handshakeSendFinish ctx = do
 	sendPacket ctx (Handshake $ Finished $ B.unpack cf)
 
 {- after receiving a client hello, we need to redo a handshake -}
-handshake :: MonadIO m => TLSCtx -> m ()
-handshake ctx = do
+handshakeServer :: MonadIO m => TLSCtx -> m ()
+handshakeServer ctx = do
 	handshakeSendServerData ctx
 	liftIO $ hFlush $ getHandle ctx
 
@@ -109,7 +109,7 @@ listen ctx = do
 	case pkts of
 		Right [Handshake hs] -> handleClientHello ctx hs
 		x                    -> fail ("unexpected type received. expecting handshake ++ " ++ show x)
-	handshake ctx
+	handshakeServer ctx
 
 {- | recvData get data out of Data packet, and automatically renegociate if
  - a Handshake ClientHello is received -}

Stunnel.hs

@@ -50,7 +50,7 @@ tlsclient :: Handle -> TLSCtx -> IO ()
 tlsclient srchandle dsthandle = do
 	hSetBuffering srchandle NoBuffering
 
-	C.initiate dsthandle
+	handshake dsthandle
 
 	loopUntil $ do
 		b <- readOne srchandle

Tests/Connection.hs

@@ -171,7 +171,7 @@ testInitiate spCert = do
 			writeChan queue d
 			return ()
 		tlsClient queue handle = do
-			C.initiate handle
+			handshake handle
 			d <- readChan queue
 			sendData handle d
 			return ()