diff --git a/Network/TLS/Client.hs b/Network/TLS/Client.hs index 09c01d6..d045c64 100644 --- a/Network/TLS/Client.hs +++ b/Network/TLS/Client.hs @@ -1,117 +1,9 @@ --- | --- Module : Network.TLS.Client --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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" diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs index 5a9f448..4a93065 100644 --- a/Network/TLS/Core.hs +++ b/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 - diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs index 3281dcf..5a814d2 100644 --- a/Network/TLS/Server.hs +++ b/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 -} diff --git a/Stunnel.hs b/Stunnel.hs index e4ca4f9..8eb8151 100644 --- a/Stunnel.hs +++ b/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 diff --git a/Tests/Connection.hs b/Tests/Connection.hs index 1980eb9..9300acb 100644 --- a/Tests/Connection.hs +++ b/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 ()