Switch handshake to exception instead of returning a bool.

Bool return value doesn't provide any information on why the handshake failed,
hence remove the Bool value, and return (), and in case of handshake failure,
raise a HandshakeFailed exception with the TLSError associated with it.

Network/TLS/Core.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 -- |
 -- Module      : Network.TLS.Core
 -- License     : BSD-style
@@ -21,6 +22,7 @@ module Network.TLS.Core
 	-- * Initialisation and Termination of context
 	, bye
 	, handshake
+	, HandshakeFailed
 
 	-- * High level API
 	, sendData
@@ -39,6 +41,7 @@ import Network.TLS.Receiving
 import Network.TLS.Measurement
 import Network.TLS.Wire (encodeWord16)
 import Data.Maybe
+import Data.Data
 import Data.List (intersect, find)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
@@ -51,10 +54,18 @@ import System.IO (Handle)
 import System.IO.Error (mkIOError, eofErrorType)
 import Prelude hiding (catch)
 
+data HandshakeFailed = HandshakeFailed TLSError
+	deriving (Show,Eq,Typeable)
+
+instance Exception HandshakeFailed
+
 errorToAlert :: TLSError -> Packet
 errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]
 errorToAlert _                           = Alert [(AlertLevel_Fatal, InternalError)]
 
+handshakeFailed :: TLSError -> IO ()
+handshakeFailed err = throwIO $ HandshakeFailed err
+
 readExact :: MonadIO m => TLSCtx c -> Int -> m Bytes
 readExact ctx sz = do
 	hdrbs <- liftIO $ connectionRecv ctx sz
@@ -441,15 +452,15 @@ handshakeServer ctx = do
 
 -- | Handshake for a new TLS connection
 -- This is to be called at the beginning of a connection, and during renegociation
-handshake :: MonadIO m => TLSCtx c -> m Bool
+handshake :: MonadIO m => TLSCtx c -> m ()
 handshake ctx = do
 	cc <- usingState_ ctx (stClientContext <$> get)
 	liftIO $ handleException $ if cc then handshakeClient ctx else handshakeServer ctx
 	where
-		handleException f = catch (f >> return True) (\e -> handler e >> return False)
+		handleException f = catch f $ \exception -> do
-		handler e = case fromException e of
+			let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception
-			Just err -> sendPacket ctx (errorToAlert err)
+			sendPacket ctx (errorToAlert tlserror)
-			Nothing  -> sendPacket ctx (errorToAlert $ Error_Misc $ show e)
+			handshakeFailed tlserror
 
 -- | sendData sends a bunch of data.
 -- It will automatically chunk data to acceptable packet size

Tests.hs

@@ -170,14 +170,12 @@ prop_handshake_initiate = do
 	return ()
 	where
 		tlsServer ctx queue = do
-			hSuccess <- handshake ctx
+			handshake ctx
-			unless hSuccess $ fail "handshake failed on server side"
 			d <- recvData ctx
 			writeChan queue d
 			return ()
 		tlsClient queue ctx = do
-			hSuccess <- handshake ctx
+			handshake ctx
-			unless hSuccess $ fail "handshake failed on client side"
 			d <- readChan queue
 			sendData ctx d
 			bye ctx
@@ -199,16 +197,13 @@ prop_handshake_renegociation = do
 	return ()
 	where
 		tlsServer ctx queue = do
-			hSuccess <- handshake ctx
+			handshake ctx
-			unless hSuccess $ fail "handshake failed on server side"
 			d <- recvData ctx
 			writeChan queue d
 			return ()
 		tlsClient queue ctx = do
-			hSuccess <- handshake ctx
+			handshake ctx
-			unless hSuccess $ fail "handshake failed on client side"
+			handshake ctx
-			hSuccess2 <- handshake ctx
-			unless hSuccess2 $ fail "renegociation handshake failed"
 			d <- readChan queue
 			sendData ctx d
 			bye ctx
@@ -239,23 +234,21 @@ prop_handshake_session_resumption = do
 
 	{- 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 <- L.pack <$> pick (someWords8 256)
+	d2 <- L.pack <$> pick (someWords8 256)
-	run $ writeChan startQueue d
+	run $ writeChan startQueue d2
 
-	dres <- run $ readChan resultQueue
+	dres2 <- run $ readChan resultQueue
-	d `assertEq` dres
+	d2 `assertEq` dres2
 
 	return ()
 	where
 		tlsServer ctx queue = do
-			hSuccess <- handshake ctx
+			handshake ctx
-			unless hSuccess $ fail "resumption failed on server side"
 			d <- recvData ctx
 			writeChan queue d
 			return ()
 		tlsClient queue ctx = do
-			hSuccess <- handshake ctx
+			handshake ctx
-			unless hSuccess $ fail "resumption failed on client side"
 			d <- readChan queue
 			sendData ctx d
 			bye ctx