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.
This commit is contained in:
parent
3b271b0c03
commit
c846d9a360
2 changed files with 27 additions and 23 deletions
|
@ -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)
|
||||
handler e = case fromException e of
|
||||
Just err -> sendPacket ctx (errorToAlert err)
|
||||
Nothing -> sendPacket ctx (errorToAlert $ Error_Misc $ show e)
|
||||
handleException f = catch f $ \exception -> do
|
||||
let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception
|
||||
sendPacket ctx (errorToAlert tlserror)
|
||||
handshakeFailed tlserror
|
||||
|
||||
-- | sendData sends a bunch of data.
|
||||
-- It will automatically chunk data to acceptable packet size
|
||||
|
|
29
Tests.hs
29
Tests.hs
|
@ -170,14 +170,12 @@ prop_handshake_initiate = do
|
|||
return ()
|
||||
where
|
||||
tlsServer ctx queue = do
|
||||
hSuccess <- handshake ctx
|
||||
unless hSuccess $ fail "handshake failed on server side"
|
||||
handshake ctx
|
||||
d <- recvData ctx
|
||||
writeChan queue d
|
||||
return ()
|
||||
tlsClient queue ctx = do
|
||||
hSuccess <- handshake ctx
|
||||
unless hSuccess $ fail "handshake failed on client side"
|
||||
handshake ctx
|
||||
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
|
||||
unless hSuccess $ fail "handshake failed on server side"
|
||||
handshake ctx
|
||||
d <- recvData ctx
|
||||
writeChan queue d
|
||||
return ()
|
||||
tlsClient queue ctx = do
|
||||
hSuccess <- handshake ctx
|
||||
unless hSuccess $ fail "handshake failed on client side"
|
||||
hSuccess2 <- handshake ctx
|
||||
unless hSuccess2 $ fail "renegociation handshake failed"
|
||||
handshake ctx
|
||||
handshake ctx
|
||||
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)
|
||||
run $ writeChan startQueue d
|
||||
d2 <- L.pack <$> pick (someWords8 256)
|
||||
run $ writeChan startQueue d2
|
||||
|
||||
dres <- run $ readChan resultQueue
|
||||
d `assertEq` dres
|
||||
dres2 <- run $ readChan resultQueue
|
||||
d2 `assertEq` dres2
|
||||
|
||||
return ()
|
||||
where
|
||||
tlsServer ctx queue = do
|
||||
hSuccess <- handshake ctx
|
||||
unless hSuccess $ fail "resumption failed on server side"
|
||||
handshake ctx
|
||||
d <- recvData ctx
|
||||
writeChan queue d
|
||||
return ()
|
||||
tlsClient queue ctx = do
|
||||
hSuccess <- handshake ctx
|
||||
unless hSuccess $ fail "resumption failed on client side"
|
||||
handshake ctx
|
||||
d <- readChan queue
|
||||
sendData ctx d
|
||||
bye ctx
|
||||
|
|
Loading…
Reference in a new issue