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
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)
handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m ()
handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do
handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
updateMeasure ctx incrementNbHandshakes
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
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
makeServerHello session = do
srand <- getStateRNG ctx 32 >>= return . ServerRandom
case privKeys of
(Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey
_ -> return ()
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
sendPacket ctx $ Handshake [ serverhello, Certificates srvCerts ]
when needKeyXchg $ do
let skg = SKX_RSA Nothing
sendPacket ctx (Handshake [ServerKeyXchg skg])
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])
sendPacket ctx (Handshake [ServerHelloDone])
extractCAname :: X509 -> DistinguishedName
extractCAname cert = certSubjectDN (x509Cert cert)
handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello"
recvClientData :: MonadIO m => ServerParams -> Context -> m ()
recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)
where
processClientCertificate (Certificates certs) = do
usage <- liftIO $ E.catch (onClientCertificate sparams certs) rejectOnException
case usage of
CertificateUsageAccept -> return ()
CertificateUsageReject reason -> certificateRejected reason
usingState_ ctx $ setClientCertChain certs
return $ RecvStateHandshake processClientKeyExchange
processClientCertificate p = processClientKeyExchange p
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
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)
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)
verif <- usingState_ ctx $ verifyRSA hsh signature bs
case verif of
True -> do
Just certs <- usingState_ ctx $ getClientCertChain
usingState_ ctx $ setClientCertificateChain certs
return ()
False -> do
res <- liftIO $ onUnverifiedClientCert sparams
if res
then do
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")