322 lines
15 KiB
Haskell
322 lines
15 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.Context
|
|
import Network.TLS.Session
|
|
import Network.TLS.Struct
|
|
import Network.TLS.Cipher
|
|
import Network.TLS.Compression
|
|
import Network.TLS.Extension
|
|
import Network.TLS.Util (catchException, fromJust)
|
|
import Network.TLS.IO
|
|
import Network.TLS.Types
|
|
import Network.TLS.State hiding (getNegotiatedProtocol)
|
|
import Network.TLS.Handshake.State
|
|
import Network.TLS.Handshake.Process
|
|
import Network.TLS.Measurement
|
|
import Data.Maybe (isJust)
|
|
import Data.List (intersect, sortBy)
|
|
import qualified Data.ByteString as B
|
|
import Data.ByteString.Char8 ()
|
|
|
|
import Control.Applicative ((<$>), (<*>))
|
|
import Control.Monad.State
|
|
|
|
import Network.TLS.Handshake.Signature
|
|
import Network.TLS.Handshake.Common
|
|
import Network.TLS.Handshake.Certificate
|
|
import Network.TLS.X509
|
|
|
|
-- 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 = liftIO $ 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 :: ServerParams -> Context -> Handshake -> IO ()
|
|
handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ 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
|
|
processHandshake ctx clientHello
|
|
|
|
when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
|
|
chosenVersion <- case findHighestVersionFrom clientVersion (pAllowedVersions params) of
|
|
Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion)
|
|
Just v -> return v
|
|
|
|
let usedCipher = (onCipherChoosing sparams) chosenVersion
|
|
$ filter (cipherAllowedForVersion chosenVersion) commonCiphers
|
|
|
|
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)
|
|
resumeSessionData <- case clientSession of
|
|
(Session (Just clientSessionId)) -> withSessionManager params (\s -> liftIO $ sessionResume s clientSessionId)
|
|
(Session Nothing) -> return Nothing
|
|
doHandshake sparams ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts
|
|
|
|
where
|
|
params = ctxParams ctx
|
|
commonCipherIDs = intersect ciphers (map cipherID $ pCiphers params)
|
|
commonCiphers = filter (flip elem commonCipherIDs . cipherID) (pCiphers params)
|
|
commonCompressions = compressionIntersectID (pCompressions params) compressions
|
|
usedCompression = head commonCompressions
|
|
|
|
|
|
handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello"
|
|
|
|
doHandshake :: ServerParams -> Context -> Version -> Cipher
|
|
-> Compression -> Session -> Maybe SessionData
|
|
-> [(ExtensionID, a)] -> IO ()
|
|
doHandshake sparams ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do
|
|
case resumeSessionData of
|
|
Nothing -> do
|
|
handshakeSendServerData
|
|
liftIO $ contextFlush ctx
|
|
-- Receive client info until client Finished.
|
|
recvClientData sparams ctx
|
|
sendChangeCipherAndFinish ctx ServerRole
|
|
Just sessionData -> do
|
|
usingState_ ctx (setSession clientSession True)
|
|
serverhello <- makeServerHello clientSession
|
|
sendPacket ctx $ Handshake [serverhello]
|
|
usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData
|
|
sendChangeCipherAndFinish ctx ServerRole
|
|
recvChangeCipherAndFinish ctx
|
|
handshakeTerminate ctx
|
|
where
|
|
params = ctxParams ctx
|
|
srvCerts = fmap fst $ pCertificates params
|
|
privKey = join $ fmap snd $ pCertificates params
|
|
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 privKey of
|
|
Just privkey -> usingHState 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 ClientRole
|
|
svf <- getVerifiedData ServerRole
|
|
return $ extensionEncode (SecureRenegotiation cvf $ Just svf)
|
|
return [ (0xff01, vf) ]
|
|
else return []
|
|
nextProtocols <-
|
|
if clientRequestedNPN
|
|
then liftIO $ onSuggestNextProtocols sparams
|
|
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 chosenVersion)
|
|
usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression
|
|
return $ ServerHello chosenVersion 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 (maybe (CertificateChain []) id srvCerts) ]
|
|
|
|
-- send server key exchange if needed
|
|
skx <- case cipherKeyExchange usedCipher of
|
|
_ -> return Nothing
|
|
maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx
|
|
|
|
-- 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 getVersion
|
|
let certTypes = [ CertificateType_RSA_Sign ]
|
|
hashSigs = if usedVersion < TLS12
|
|
then Nothing
|
|
else Just (pHashSignatures $ ctxParams ctx)
|
|
creq = CertRequest certTypes hashSigs
|
|
(map extractCAname $ serverCACertificates sparams)
|
|
usingHState ctx $ setCertReqSent True
|
|
sendPacket ctx (Handshake [creq])
|
|
|
|
-- Send HelloDone
|
|
sendPacket ctx (Handshake [ServerHelloDone])
|
|
|
|
extractCAname :: SignedCertificate -> DistinguishedName
|
|
extractCAname cert = certSubjectDN $ getCertificate cert
|
|
|
|
-- | receive Client data in handshake until the Finished handshake.
|
|
--
|
|
-- <- [certificate]
|
|
-- <- client key xchg
|
|
-- <- [cert verify]
|
|
-- <- change cipher
|
|
-- <- [NPN]
|
|
-- <- finish
|
|
--
|
|
recvClientData :: ServerParams -> Context -> IO ()
|
|
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 $ catchException (onClientCertificate sparams certs) rejectOnException
|
|
case usage of
|
|
CertificateUsageAccept -> return ()
|
|
CertificateUsageReject reason -> certificateRejected reason
|
|
|
|
-- Remember cert chain for later use.
|
|
--
|
|
usingHState 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 dsig@(DigitallySigned mbHashSig _))]) = do
|
|
processHandshake ctx hs
|
|
|
|
checkValidClientCertChain "change cipher message expected"
|
|
|
|
usedVersion <- usingState_ ctx getVersion
|
|
-- Fetch all handshake messages up to now.
|
|
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
|
|
(hashMethod, toVerify) <- prepareCertificateVerifySignatureData ctx usedVersion mbHashSig msgs
|
|
|
|
-- Verify the signature.
|
|
verif <- signatureVerifyWithHashDescr ctx SignatureRSA hashMethod toVerify dsig
|
|
|
|
case verif of
|
|
True -> do
|
|
-- When verification succeeds, commit the
|
|
-- client certificate chain to the context.
|
|
--
|
|
Just certs <- usingHState 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 <- usingHState ctx $ getClientCertChain
|
|
usingState_ ctx $ setClientCertificateChain certs
|
|
else throwCore $ Error_Protocol ("verification failed", True, BadCertificate)
|
|
return $ RecvStateNext expectChangeCipher
|
|
|
|
processCertificateVerify p = do
|
|
chain <- usingHState ctx $ getClientCertChain
|
|
case chain of
|
|
Just cc | isNullCertificateChain cc -> return ()
|
|
| otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage)
|
|
Nothing -> 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")
|
|
|
|
checkValidClientCertChain msg = do
|
|
chain <- usingHState ctx $ getClientCertChain
|
|
let throwerror = Error_Protocol (msg , True, UnexpectedMessage)
|
|
case chain of
|
|
Nothing -> throwCore throwerror
|
|
Just cc | isNullCertificateChain cc -> throwCore throwerror
|
|
| otherwise -> return ()
|
|
|
|
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
|
|
findHighestVersionFrom clientVersion allowedVersions =
|
|
case filter (clientVersion >=) $ reverse $ sortBy compare allowedVersions of
|
|
[] -> Nothing
|
|
v:_ -> Just v
|