{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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")