2012-04-27 06:28:17 +00:00
|
|
|
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
|
2012-04-27 06:29:35 +00:00
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.Handshake
|
|
|
|
-- License : BSD-style
|
|
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : unknown
|
|
|
|
--
|
2012-04-27 06:28:17 +00:00
|
|
|
module Network.TLS.Handshake
|
|
|
|
( handshake
|
|
|
|
, handshakeServerWith
|
|
|
|
, handshakeClient
|
|
|
|
, HandshakeFailed(..)
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Network.TLS.Context
|
|
|
|
import Network.TLS.Struct
|
|
|
|
import Network.TLS.IO
|
|
|
|
|
2012-08-18 21:46:53 +00:00
|
|
|
import Network.TLS.Handshake.Common
|
2012-08-18 22:05:56 +00:00
|
|
|
import Network.TLS.Handshake.Client
|
2012-08-18 22:13:13 +00:00
|
|
|
import Network.TLS.Handshake.Server
|
2012-07-21 21:24:47 +00:00
|
|
|
|
2012-08-18 22:13:13 +00:00
|
|
|
import Control.Monad.State
|
|
|
|
import Control.Exception (fromException)
|
|
|
|
import qualified Control.Exception as E
|
2012-04-27 06:28:17 +00:00
|
|
|
|
|
|
|
-- | Handshake for a new TLS connection
|
|
|
|
-- This is to be called at the beginning of a connection, and during renegotiation
|
|
|
|
handshake :: MonadIO m => Context -> m ()
|
|
|
|
handshake ctx = do
|
2012-07-12 08:02:10 +00:00
|
|
|
let handshakeF = case roleParams $ ctxParams ctx of
|
|
|
|
Server sparams -> handshakeServer sparams
|
|
|
|
Client cparams -> handshakeClient cparams
|
|
|
|
liftIO $ handleException $ handshakeF ctx
|
2012-04-27 06:28:17 +00:00
|
|
|
where
|
2012-08-18 22:13:13 +00:00
|
|
|
handleException f = E.catch f $ \exception -> do
|
2012-04-27 06:28:17 +00:00
|
|
|
let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception
|
|
|
|
setEstablished ctx False
|
|
|
|
sendPacket ctx (errorToAlert tlserror)
|
|
|
|
handshakeFailed tlserror
|