319 lines
16 KiB
Haskell
319 lines
16 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
|
|
-- |
|
|
-- Module : Network.TLS.Handshake.Server
|
|
-- License : BSD-style
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
-- Stability : experimental
|
|
-- Portability : unknown
|
|
--
|
|
module Network.TLS.Handshake.Server
|
|
( handshakeServer
|
|
, handshakeServerWith
|
|
) where
|
|
|
|
import Network.TLS.Crypto
|
|
import Network.TLS.Context
|
|
import Network.TLS.Session
|
|
import Network.TLS.Struct
|
|
import Network.TLS.Cipher
|
|
import Network.TLS.Compression
|
|
import Network.TLS.Packet
|
|
import Network.TLS.Extension
|
|
import Network.TLS.IO
|
|
import Network.TLS.State hiding (getNegotiatedProtocol)
|
|
import Network.TLS.Receiving
|
|
import Network.TLS.Measurement
|
|
import Data.Maybe
|
|
import Data.List (intersect)
|
|
import qualified Data.ByteString as B
|
|
import Data.ByteString.Char8 ()
|
|
|
|
import Data.Certificate.X509(X509, certSubjectDN, x509Cert)
|
|
|
|
import Control.Applicative ((<$>))
|
|
import Control.Monad.State
|
|
import qualified Control.Exception as E
|
|
|
|
import Network.TLS.Handshake.Signature
|
|
import Network.TLS.Handshake.Common
|
|
import Network.TLS.Handshake.Certificate
|
|
|
|
-- Put the server context in handshake mode.
|
|
--
|
|
-- Expect to receive as first packet a client hello handshake message
|
|
--
|
|
-- This is just a helper to pop the next message from the recv layer,
|
|
-- and call handshakeServerWith.
|
|
handshakeServer :: MonadIO m => ServerParams -> Context -> m ()
|
|
handshakeServer sparams ctx = do
|
|
hss <- recvPacketHandshake ctx
|
|
case hss of
|
|
[ch] -> handshakeServerWith sparams ctx ch
|
|
_ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss)
|
|
|
|
-- | Put the server context in handshake mode.
|
|
--
|
|
-- Expect a client hello message as parameter.
|
|
-- This is useful when the client hello has been already poped from the recv layer to inspect the packet.
|
|
--
|
|
-- When the function returns, a new handshake has been succesfully negociated.
|
|
-- On any error, a HandshakeFailed exception is raised.
|
|
--
|
|
-- handshake protocol (<- receiving, -> sending, [] optional):
|
|
-- (no session) (session resumption)
|
|
-- <- client hello <- client hello
|
|
-- -> server hello -> server hello
|
|
-- -> [certificate]
|
|
-- -> [server key xchg]
|
|
-- -> [cert request]
|
|
-- -> hello done
|
|
-- <- [certificate]
|
|
-- <- client key xchg
|
|
-- <- [cert verify]
|
|
-- <- change cipher -> change cipher
|
|
-- <- [NPN]
|
|
-- <- finish -> finish
|
|
-- -> change cipher <- change cipher
|
|
-- -> finish <- finish
|
|
--
|
|
handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m ()
|
|
handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do
|
|
-- check if policy allow this new handshake to happens
|
|
handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
|
|
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
|
|
updateMeasure ctx incrementNbHandshakes
|
|
|
|
-- Handle Client hello
|
|
usingState_ ctx $ processHandshake clientHello
|
|
when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
|
|
when (not $ elem ver (pAllowedVersions params)) $
|
|
throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)
|
|
when (commonCipherIDs == []) $
|
|
throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)
|
|
when (null commonCompressions) $
|
|
throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure)
|
|
usingState_ ctx $ modify (\st -> st
|
|
{ stVersion = ver
|
|
, stPendingCipher = Just usedCipher
|
|
, stCompression = usedCompression
|
|
})
|
|
|
|
resumeSessionData <- case clientSession of
|
|
(Session (Just clientSessionId)) -> withSessionManager params (\s -> liftIO $ sessionResume s clientSessionId)
|
|
(Session Nothing) -> return Nothing
|
|
case resumeSessionData of
|
|
Nothing -> do
|
|
handshakeSendServerData
|
|
liftIO $ contextFlush ctx
|
|
-- Receive client info until client Finished.
|
|
recvClientData sparams ctx
|
|
sendChangeCipherAndFinish ctx False
|
|
Just sessionData -> do
|
|
usingState_ ctx (setSession clientSession True)
|
|
serverhello <- makeServerHello clientSession
|
|
sendPacket ctx $ Handshake [serverhello]
|
|
usingState_ ctx $ setMasterSecret $ sessionSecret sessionData
|
|
sendChangeCipherAndFinish ctx False
|
|
recvChangeCipherAndFinish ctx
|
|
handshakeTerminate ctx
|
|
where
|
|
params = ctxParams ctx
|
|
commonCipherIDs = intersect ciphers (map cipherID $ pCiphers params)
|
|
commonCiphers = filter (flip elem commonCipherIDs . cipherID) (pCiphers params)
|
|
usedCipher = (onCipherChoosing sparams) ver commonCiphers
|
|
commonCompressions = compressionIntersectID (pCompressions params) compressions
|
|
usedCompression = head commonCompressions
|
|
srvCerts = map fst $ pCertificates params
|
|
privKeys = map snd $ pCertificates params
|
|
needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher
|
|
clientRequestedNPN = isJust $ lookup extensionID_NextProtocolNegotiation exts
|
|
|
|
---
|
|
|
|
-- When the client sends a certificate, check whether
|
|
-- it is acceptable for the application.
|
|
--
|
|
---
|
|
|
|
makeServerHello session = 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.
|
|
secReneg <- usingState_ ctx getSecureRenegotiation
|
|
secRengExt <- if secReneg
|
|
then do
|
|
vf <- usingState_ ctx $ do
|
|
cvf <- getVerifiedData True
|
|
svf <- getVerifiedData False
|
|
return $ extensionEncode (SecureRenegotiation cvf $ Just svf)
|
|
return [ (0xff01, vf) ]
|
|
else return []
|
|
nextProtocols <-
|
|
if clientRequestedNPN
|
|
then liftIO $ onSuggestNextProtocols params
|
|
else return Nothing
|
|
npnExt <- case nextProtocols of
|
|
Just protos -> do usingState_ ctx $ do setExtensionNPN True
|
|
setServerNextProtocolSuggest protos
|
|
return [ ( extensionID_NextProtocolNegotiation
|
|
, extensionEncode $ NextProtocolNegotiation protos) ]
|
|
Nothing -> return []
|
|
let extensions = secRengExt ++ npnExt
|
|
usingState_ ctx (setVersion ver >> setServerRandom srand)
|
|
return $ ServerHello ver srand session (cipherID usedCipher)
|
|
(compressionID usedCompression) extensions
|
|
|
|
handshakeSendServerData = do
|
|
serverSession <- newSession ctx
|
|
usingState_ ctx (setSession serverSession False)
|
|
serverhello <- makeServerHello serverSession
|
|
-- send ServerHello & Certificate & ServerKeyXchg & CertReq
|
|
sendPacket ctx $ Handshake [ serverhello, 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 configured, send a certificate request
|
|
-- with the DNs of all confgure CA
|
|
-- certificates.
|
|
--
|
|
when (serverWantClientCert sparams) $ do
|
|
usedVersion <- usingState_ ctx $ stVersion <$> get
|
|
let certTypes = [ CertificateType_RSA_Sign ]
|
|
hashSigs = if usedVersion < TLS12
|
|
then Nothing
|
|
else Just (pHashSignatures $ ctxParams ctx)
|
|
creq = CertRequest certTypes hashSigs
|
|
(map extractCAname $ serverCACertificates sparams)
|
|
usingState_ ctx $ setCertReqSent True
|
|
sendPacket ctx (Handshake [creq])
|
|
|
|
-- Send HelloDone
|
|
sendPacket ctx (Handshake [ServerHelloDone])
|
|
|
|
extractCAname :: X509 -> DistinguishedName
|
|
extractCAname cert = certSubjectDN (x509Cert cert)
|
|
|
|
handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello"
|
|
|
|
-- | receive Client data in handshake until the Finished handshake.
|
|
--
|
|
-- <- [certificate]
|
|
-- <- client key xchg
|
|
-- <- [cert verify]
|
|
-- <- change cipher
|
|
-- <- [NPN]
|
|
-- <- finish
|
|
--
|
|
recvClientData :: MonadIO m => ServerParams -> Context -> m ()
|
|
recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)
|
|
where
|
|
processClientCertificate (Certificates certs) = do
|
|
|
|
-- Call application callback to see whether the
|
|
-- certificate chain is acceptable.
|
|
--
|
|
usage <- liftIO $ E.catch (onClientCertificate sparams certs) rejectOnException
|
|
case usage of
|
|
CertificateUsageAccept -> return ()
|
|
CertificateUsageReject reason -> certificateRejected reason
|
|
|
|
-- Remember cert chain for later use.
|
|
--
|
|
usingState_ ctx $ setClientCertChain certs
|
|
|
|
-- FIXME: We should check whether the certificate
|
|
-- matches our request and that we support
|
|
-- verifying with that certificate.
|
|
|
|
return $ RecvStateHandshake processClientKeyExchange
|
|
|
|
processClientCertificate p = processClientKeyExchange p
|
|
|
|
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
|
|
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
|
|
|
|
-- Check whether the client correctly signed the handshake.
|
|
-- If not, ask the application on how to proceed.
|
|
--
|
|
processCertificateVerify (Handshake [hs@(CertVerify mbHashSig (CertVerifyData bs))]) = do
|
|
usingState_ ctx $ processHandshake hs
|
|
chain <- usingState_ ctx $ getClientCertChain
|
|
case chain of
|
|
Just (_:_) -> return ()
|
|
_ -> throwCore $ Error_Protocol ("change cipher message expected", True, UnexpectedMessage)
|
|
|
|
-- Fetch all handshake messages up to now.
|
|
msgs <- usingState_ ctx $ B.concat <$> getHandshakeMessages
|
|
|
|
usedVersion <- usingState_ ctx $ stVersion <$> get
|
|
|
|
(signature, hsh) <- case usedVersion of
|
|
SSL3 -> do
|
|
Just masterSecret <- usingState_ ctx $ getMasterSecret
|
|
let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs)
|
|
hsh = HashDescr id id
|
|
return (digest, hsh)
|
|
|
|
x | x == TLS10 || x == TLS11 -> do
|
|
let hashf bs' = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs')
|
|
hsh = HashDescr hashf id
|
|
return (msgs,hsh)
|
|
_ -> do
|
|
let Just sentHashSig = mbHashSig
|
|
hsh <- getHashAndASN1 sentHashSig
|
|
return (msgs,hsh)
|
|
|
|
-- Verify the signature.
|
|
verif <- usingState_ ctx $ verifyRSA hsh signature bs
|
|
|
|
case verif of
|
|
True -> do
|
|
-- When verification succeeds, commit the
|
|
-- client certificate chain to the context.
|
|
--
|
|
Just certs <- usingState_ ctx $ getClientCertChain
|
|
usingState_ ctx $ setClientCertificateChain certs
|
|
return ()
|
|
|
|
False -> do
|
|
-- Either verification failed because of an
|
|
-- invalid format (with an error message), or
|
|
-- the signature is wrong. In either case,
|
|
-- ask the application if it wants to
|
|
-- proceed, we will do that.
|
|
res <- liftIO $ onUnverifiedClientCert sparams
|
|
if res
|
|
then do
|
|
-- When verification fails, but the
|
|
-- application callbacks accepts, we
|
|
-- also commit the client certificate
|
|
-- chain to the context.
|
|
Just certs <- usingState_ ctx $ getClientCertChain
|
|
usingState_ ctx $ setClientCertificateChain certs
|
|
else throwCore $ Error_Protocol ("verification failed", True, BadCertificate)
|
|
return $ RecvStateNext expectChangeCipher
|
|
|
|
processCertificateVerify p = do
|
|
chain <- usingState_ ctx $ getClientCertChain
|
|
case chain of
|
|
Just (_:_) -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage)
|
|
_ -> return ()
|
|
expectChangeCipher p
|
|
|
|
expectChangeCipher ChangeCipherSpec = do
|
|
npn <- usingState_ ctx getExtensionNPN
|
|
return $ RecvStateHandshake $ if npn then expectNPN else expectFinish
|
|
expectChangeCipher p = unexpected (show p) (Just "change cipher")
|
|
|
|
expectNPN (HsNextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish
|
|
expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegotiation")
|
|
|
|
expectFinish (Finished _) = return RecvStateDone
|
|
expectFinish p = unexpected (show p) (Just "Handshake Finished")
|