From 7237bec83e8e9024db5caba895bd0a2bd486e27a Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Wed, 2 Mar 2011 07:35:25 +0000 Subject: [PATCH] fold handshake stuff from server to core. --- Network/TLS/Core.hs | 83 ++++++++++++++++++++++++++++++-- Network/TLS/Server.hs | 108 +----------------------------------------- Stunnel.hs | 3 +- Tests/Connection.hs | 2 +- 4 files changed, 83 insertions(+), 113 deletions(-) diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs index 4a93065..9792bf9 100644 --- a/Network/TLS/Core.hs +++ b/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 () diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs index 08894e0..b524a55 100644 --- a/Network/TLS/Server.hs +++ b/Network/TLS/Server.hs @@ -1,115 +1,9 @@ --- | --- Module : Network.TLS.Server --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 (recvData) where -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 -} diff --git a/Stunnel.hs b/Stunnel.hs index 8eb8151..20251a8 100644 --- a/Stunnel.hs +++ b/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 diff --git a/Tests/Connection.hs b/Tests/Connection.hs index 9300acb..82d7286 100644 --- a/Tests/Connection.hs +++ b/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 ()