fold handshake stuff from server to core.
This commit is contained in:
Vincent Hanquez
parent
fc598287ad
commit
7237bec83e
4 changed files with 83 additions and 113 deletions
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -1,115 +1,9 @@
|
|||
-- |
|
||||
-- Module : Network.TLS.Server
|
||||
-- License : BSD-style
|
||||
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
||||
-- 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 -}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in a new issue