fold handshake stuff from server to core.

Network/TLS/Core.hs

@@ -38,8 +38,9 @@ import Network.TLS.State
 import Network.TLS.Sending
 import Network.TLS.Receiving
 import Network.TLS.SRandom
+import Data.Maybe
 import Data.Certificate.X509
-import Data.List (intercalate, find)
+import Data.List (intersect, intercalate, find)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
@@ -110,7 +111,7 @@ usingState_ :: MonadIO m => TLSCtx -> TLSSt a -> m a
 usingState_ ctx f = do
 	ret <- usingState ctx f
 	case ret of
-		Left err -> error "assertion failed, error in path without an error"
+		Left err -> error ("assertion failed, wrong use of state_: " ++ show err)
 		Right r  -> return r
 
 getStateRNG :: MonadIO m => TLSCtx -> Int -> m Bytes
@@ -221,6 +222,82 @@ handshakeClient ctx = do
 
 		processServerInfo _ = return ()
 
+handshakeServerWith :: MonadIO m => TLSCtx -> Handshake -> m ()
+handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do
+	-- Handle Client hello
+	when (not $ elem ver (pAllowedVersions params)) $ fail "unsupported version"
+	when (commonCiphers == []) $ fail "no common cipher supported"
+	when (commonCompressions == []) $ fail "no common compression supported"
+	usingState_ ctx $ modify (\st -> st
+		{ stVersion = ver
+		, stCipher  = Just usedCipher
+		--, stCompression = Just usedCompression
+		})
+
+	-- send Server Data until ServerHelloDone
+	handshakeSendServerData
+	liftIO $ hFlush $ getHandle ctx
+
+	-- Receive client info until client Finished.
+	whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacket ctx)
+
+	sendPacket ctx ChangeCipherSpec
+
+	-- Send Finish
+	cf <- usingState_ ctx $ getHandshakeDigest False
+	sendPacket ctx (Handshake $ Finished $ B.unpack cf)
+
+	liftIO $ hFlush $ getHandle ctx
+	return ()
+	where
+		params             = getParams 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)
+		srvCerts           = map fst $ pCertificates params
+		privKeys           = map snd $ pCertificates params
+		needKeyXchg        = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher
+
+		handshakeSendServerData = do
+			srand <- getStateRNG ctx 32 >>= return . ServerRandom
+
+			case privKeys of
+				(Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey
+				_                  -> return () -- return a sensible error
+
+			-- in TLS12, we need to check as well the certificates we are sending if they have in the extension
+			-- the necessary bits set.
+
+			-- send ServerHello & Certificate & ServerKeyXchg & CertReq
+			sendPacket ctx $ Handshake $ ServerHello ver srand
+			                                         (Session Nothing)
+			                                         (cipherID usedCipher)
+			                                         (compressionID usedCompression)
+			                                         Nothing
+			sendPacket ctx (Handshake $ Certificates srvCerts)
+			when needKeyXchg $ do
+				let skg = SKX_RSA Nothing
+				sendPacket ctx (Handshake $ ServerKeyXchg skg)
+			-- FIXME we don't do this on a Anonymous server
+			when (pWantClientCert params) $ do
+				let certTypes = [ CertificateType_RSA_Sign ]
+				let creq = CertRequest certTypes Nothing [0,0,0]
+				sendPacket ctx (Handshake creq)
+			-- Send HelloDone
+			sendPacket ctx (Handshake ServerHelloDone)
+
+handshakeServerWith _ _ = do
+	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 ctx = do
+	pkts <- recvPacket ctx
+	case pkts of
+		Right [Handshake hs] -> handshakeServerWith ctx hs
+		x                    -> fail ("unexpected type received. expecting handshake ++ " ++ show x)
+
 {-| 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 ()
@@ -228,7 +305,7 @@ handshake ctx = do
 	cc <- usingState_ ctx (stClientContext <$> get)
 	if cc
 		then handshakeClient ctx
-		else undefined
+		else handshakeServer ctx
 
 {- | sendData sends a bunch of data -}
 sendData :: MonadIO m => TLSCtx -> L.ByteString -> m ()

Network/TLS/Server.hs

@@ -1,115 +1,9 @@
--- |
+module Network.TLS.Server (recvData) where
--- Module      : Network.TLS.Server
--- License     : BSD-style
--- Maintainer  : Vincent Hanquez <vincent@snarc.org>
--- Stability   : experimental
--- Portability : unknown
---
--- the Server module contains the necessary calls to create a listening TLS socket
--- aka. a server socket.
---
 
-module Network.TLS.Server
-	( listen
-	, recvData
-	) where
-
-import Data.Maybe
-import Data.List (intersect, find)
 import Control.Monad.Trans
-import Control.Monad.State
-import Control.Applicative ((<$>))
 import Network.TLS.Core
-import Network.TLS.Cipher
 import Network.TLS.Struct
-import Network.TLS.State
-import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
-import System.IO (hFlush)
-
-handleClientHello :: MonadIO m => TLSCtx -> Handshake -> m ()
-handleClientHello ctx (ClientHello ver _ _ ciphers compressionID _) = do
-	let cfg = getParams ctx
-	when (not $ elem ver (pAllowedVersions cfg)) $ do
-		{- unsupported version -}
-		fail "unsupported version"
-
-	let commonCiphers = intersect ciphers (map cipherID $ pCiphers cfg)
-	when (commonCiphers == []) $ do
-		{- unsupported cipher -}
-		fail ("unsupported cipher: " ++ show ciphers ++ " : server : " ++ (show $ map cipherID $ pCiphers cfg))
-
-	when (not $ elem 0 compressionID) $ do
-		{- unsupported compression -}
-		fail "unsupported compression"
-
-	usingState_ ctx $ modify (\st -> st
-		{ stVersion = ver
-		, stCipher = find (\c -> cipherID c == (head commonCiphers)) (pCiphers cfg)
-		})
-
-handleClientHello _ _ = do
-	fail "unexpected handshake type received. expecting client hello"
-
-handshakeSendServerData :: MonadIO m => TLSCtx -> m ()
-handshakeSendServerData ctx = do
-	srand <- getStateRNG ctx 32 >>= return . ServerRandom
-	let sp = getParams ctx
-	--st    <- get >>= return . scTLSState
-
-	cipher <- usingState_ ctx (fromJust . stCipher <$> get)
-	ver    <- usingState_ ctx (stVersion <$> get)
-
-	let srvhello = ServerHello ver srand (Session Nothing) (cipherID cipher) 0 Nothing
-	let srvCerts = Certificates $ map fst $ pCertificates sp
-	case map snd $ pCertificates sp of
-		(Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey
-		_                  -> return () -- return a sensible error
-
-	-- in TLS12, we need to check as well the certificates we are sending if they have in the extension
-	-- the necessary bits set.
-	let needkeyxchg = cipherExchangeNeedMoreData $ cipherKeyExchange cipher
-
-	sendPacket ctx (Handshake srvhello)
-	sendPacket ctx (Handshake srvCerts)
-	when needkeyxchg $ do
-		let skg = SKX_RSA Nothing
-		sendPacket ctx (Handshake $ ServerKeyXchg skg)
-	-- FIXME we don't do this on a Anonymous server
-	when (pWantClientCert sp) $ do
-		let certTypes = [ CertificateType_RSA_Sign ]
-		let creq = CertRequest certTypes Nothing [0,0,0]
-		sendPacket ctx (Handshake creq)
-	sendPacket ctx (Handshake ServerHelloDone)
-
-handshakeSendFinish :: MonadIO m => TLSCtx -> m ()
-handshakeSendFinish ctx = do
-	cf <- usingState_ ctx $ getHandshakeDigest False
-	sendPacket ctx (Handshake $ Finished $ B.unpack cf)
-
-{- after receiving a client hello, we need to redo a handshake -}
-handshakeServer :: MonadIO m => TLSCtx -> m ()
-handshakeServer ctx = do
-	handshakeSendServerData ctx
-	liftIO $ hFlush $ getHandle ctx
-
-	whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacket ctx)
-
-	sendPacket ctx ChangeCipherSpec
-	handshakeSendFinish ctx
-
-	liftIO $ hFlush $ getHandle ctx
-
-	return ()
-
-{- | listen on a handle to a new TLS connection. -}
-listen :: MonadIO m => TLSCtx -> m ()
-listen ctx = do
-	pkts <- recvPacket ctx
-	case pkts of
-		Right [Handshake hs] -> handleClientHello ctx hs
-		x                    -> fail ("unexpected type received. expecting handshake ++ " ++ show x)
-	handshakeServer ctx
 
 {- | recvData get data out of Data packet, and automatically renegociate if
  - a Handshake ClientHello is received -}

Stunnel.hs

@@ -25,7 +25,6 @@ import Network.TLS.SRandom
 import Network.TLS.Struct
 
 import Network.TLS.Core
-import qualified Network.TLS.Client as C
 import qualified Network.TLS.Server as S
 
 ciphers :: [Cipher]
@@ -70,7 +69,7 @@ getRandomGen = makeSRandomGen >>= either (fail . show) (return . id)
 tlsserver srchandle dsthandle = do
 	hSetBuffering dsthandle NoBuffering
 
-	S.listen srchandle
+	handshake srchandle
 
 	loopUntil $ do
 		d <- S.recvData srchandle

Tests/Connection.hs

@@ -166,7 +166,7 @@ testInitiate spCert = do
 
 	where
 		tlsServer handle queue = do
-			S.listen handle
+			handshake handle
 			d <- S.recvData handle
 			writeChan queue d
 			return ()