{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake ( handshake , handshakeServerWith , handshakeClient , HandshakeFailed(..) ) where 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.Sending import Network.TLS.Receiving import Network.TLS.Measurement import Network.TLS.Wire (encodeWord16) import Data.Maybe import Data.Data import Data.List (intersect, find) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.Certificate.X509(X509, certIssuerDN, x509Cert) import Control.Applicative ((<$>)) import Control.Monad.State import Control.Exception (throwIO, Exception(), fromException, catch, SomeException) import Prelude hiding (catch) data HandshakeFailed = HandshakeFailed TLSError deriving (Show,Eq,Typeable) instance Exception HandshakeFailed handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err recvPacketHandshake :: MonadIO m => Context -> m [Handshake] recvPacketHandshake ctx = do pkts <- recvPacket ctx case pkts of Right (Handshake l) -> return l Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x) Left err -> throwCore err errorToAlert :: TLSError -> Packet errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] data RecvState m = RecvStateNext (Packet -> m (RecvState m)) | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone runRecvState :: MonadIO m => Context -> RecvState m -> m () runRecvState _ (RecvStateDone) = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx where loop :: MonadIO m => RecvState m -> [Handshake] -> m (RecvState m) loop recvState [] = return recvState loop (RecvStateHandshake f) (x:xs) = do nstate <- f x usingState_ ctx $ processHandshake x loop nstate xs loop _ _ = unexpected "spurious handshake" Nothing sendChangeCipherAndFinish :: MonadIO m => Context -> Bool -> m () sendChangeCipherAndFinish ctx isClient = do sendPacket ctx ChangeCipherSpec when isClient $ do suggest <- usingState_ ctx $ getServerNextProtocolSuggest case (onNPNServerSuggest (ctxParams ctx), suggest) of -- client offered, server picked up. send NPN handshake. (Just io, Just protos) -> do proto <- liftIO $ io protos sendPacket ctx (Handshake [HsNextProtocolNegotiation proto]) usingState_ ctx $ setNegotiatedProtocol proto -- client offered, server didn't pick up. do nothing. (Just _, Nothing) -> return () -- client didn't offer. do nothing. (Nothing, _) -> return () liftIO $ contextFlush ctx cf <- usingState_ ctx $ getHandshakeDigest isClient sendPacket ctx (Handshake [Finished cf]) liftIO $ contextFlush ctx recvChangeCipherAndFinish :: MonadIO m => Context -> m () recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher) where expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") unexpected :: MonadIO m => String -> Maybe [Char] -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: MonadIO m => Context -> m Session newSession ctx | pUseSession $ ctxParams ctx = getStateRNG ctx 32 >>= return . Session . Just | otherwise = return $ Session Nothing -- | when a new handshake is done, wrap up & clean up. handshakeTerminate :: MonadIO m => Context -> m () handshakeTerminate ctx = do session <- usingState_ ctx getSession -- only callback the session established if we have a session case session of Session (Just sessionId) -> do sessionData <- usingState_ ctx getSessionData withSessionManager (ctxParams ctx) (\s -> liftIO $ sessionEstablish s sessionId (fromJust sessionData)) _ -> return () -- forget all handshake data now and reset bytes counters. usingState_ ctx endHandshake updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. setEstablished ctx True return () -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: MonadIO m => ClientParams -> Context -> m () handshakeClient cparams ctx = do updateMeasure ctx incrementNbHandshakes sendClientHello recvServerHello sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish ctx True else do sendCertificate >> sendClientKeyXchg >> sendCertificateVerify sendChangeCipherAndFinish ctx True recvChangeCipherAndFinish ctx handshakeTerminate ctx where params = ctxParams ctx ver = pConnectVersion params allowedvers = pAllowedVersions params ciphers = pCiphers params compressions = pCompressions params getExtensions = sequence [secureReneg,npnExtention] >>= return . catMaybes toExtensionRaw :: Extension e => e -> ExtensionRaw toExtensionRaw ext = (extensionID ext, extensionEncode ext) secureReneg = if pUseSecureRenegotiation params then usingState_ ctx (getVerifiedData True) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing else return Nothing npnExtention = if isJust $ onNPNServerSuggest params then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] else return Nothing sendClientHello = do crand <- getStateRNG ctx 32 >>= return . ClientRandom let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams extensions <- getExtensions usingState_ ctx (startHandshakeClient ver crand) sendPacket ctx $ Handshake [ ClientHello ver crand clientSession (map cipherID ciphers) (map compressionID compressions) extensions ] expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") -- When the server requests a client certificate, we -- fetch a certificate chain from the callback in the -- client parameters and send it to the server. -- Additionally, we store the private key associated -- with the first certificate in the chain for later -- use. -- sendCertificate = do certRequested <- usingState_ ctx getClientCertRequest case certRequested of Nothing -> return () Just req -> case pClientCertParamsClient $ ctxParams ctx of Nothing -> -- FIXME: I interpret section 7.4.2 of -- RFC 2246 that a client may send an -- empty list if it does not have a -- matching certificate. -- -- When the user has not configured -- client certificates, we do exactly -- that. -- sendPacket ctx $ Handshake [Certificates []] Just ccp -> do -- FIXME: What shall we do when the -- callback throws an exception? -- certChain <- liftIO $ onCertificateRequest ccp req `catch` throwMiscErrorOnException "certificate request callback failed" -- FIXME: Currently, when the first -- client certificate has no -- associated private key (or when the -- application offered no -- certificates), we simply do not -- install the key for later use. -- This will lead to an error later -- on, but it would propbably better -- to fail explicitly. -- case certChain of (_, Just pk) : _ -> usingState_ ctx $ setClientPrivateKey pk _ -> return () -- FIXME: Check that we can sign with -- the provided certificate. -- FIXME: Check that the certificate -- matches the types requeted by the -- server. usingState_ ctx $ setClientCertSent (not $ null certChain) sendPacket ctx $ Handshake [Certificates $ map fst certChain] -- In order to send a proper certificate verify message, -- we have to do the following: -- -- 1. Determine which signing algorithm(s) the server supports -- (we currently only support RSA). -- 2. Get the current handshake hash from the handshake state. -- 3. Sign the handshake hash -- 4. Send it to the server. -- sendCertificateVerify = do -- Determine certificate request parameters. -- When no certicicate was requested, do -- nothing. -- certRequested <- usingState_ ctx getClientCertRequest case certRequested of Nothing -> return () Just _ -> do withClientCertClient ctx $ \ _ -> do -- Fetch the current handshake hash. dig <- usingState_ ctx $ getCertVerifyDigest -- FIXME: Need to chek whether the -- server supports RSA signing. -- Sign the hash. -- -- FIXME: Dows not work yet. RSA -- signing is not used correctly yet. -- sigDig <- usingState_ ctx $ signRSA dig -- Send the digest sendPacket ctx $ Handshake [CertVerify sigDig] recvServerHello = runRecvState ctx (RecvStateHandshake onServerHello) onServerHello :: MonadIO m => Handshake -> m (RecvState m) onServerHello sh@(ServerHello rver _ serverSession cipher _ exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) allowedvers of Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) Just _ -> usingState_ ctx $ setVersion ver case find ((==) cipher . cipherID) ciphers of Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) Just c -> usingState_ ctx $ setCipher c let resumingSession = case clientWantSessionResume cparams of Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing Nothing -> Nothing usingState_ ctx $ setSession serverSession (isJust resumingSession) usingState_ ctx $ processServerHello sh case extensionDecode False `fmap` (lookup extensionID_NextProtocolNegotiation exts) of Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do setExtensionNPN True setServerNextProtocolSuggest protos _ -> return () case resumingSession of Nothing -> return $ RecvStateHandshake processCertificate Just sessionData -> do usingState_ ctx (setMasterSecret $ sessionSecret sessionData) return $ RecvStateNext expectChangeCipher onServerHello p = unexpected (show p) (Just "server hello") processCertificate :: MonadIO m => Handshake -> m (RecvState m) processCertificate (Certificates certs) = do usage <- liftIO $ catch (onCertificatesRecv params $ certs) rejectOnException case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason return $ RecvStateHandshake processServerKeyExchange processCertificate p = processServerKeyExchange p processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m) processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest processServerKeyExchange p = processCertificateRequest p processCertificateRequest :: MonadIO m => Handshake -> m (RecvState m) processCertificateRequest (CertRequest cTypes sigAlgs dNames) = do -- When the server requests a client -- certificate, we simply store the -- information for later. -- usingState_ ctx $ setClientCertRequest (cTypes, sigAlgs, dNames) return $ RecvStateHandshake processServerHelloDone processCertificateRequest p = processServerHelloDone p processServerHelloDone ServerHelloDone = return RecvStateDone processServerHelloDone p = unexpected (show p) (Just "server hello data") sendClientKeyXchg = do encryptedPreMaster <- usingState_ ctx $ do xver <- stVersion <$> get prerand <- genTLSRandom 46 let premaster = encodePreMasterSecret xver prerand setMasterSecretFromPre premaster -- SSL3 implementation generally forget this length field since it's redundant, -- however TLS10 make it clear that the length field need to be present. e <- encryptRSA premaster let extra = if xver < TLS10 then B.empty else encodeWord16 $ fromIntegral $ B.length e return $ extra `B.append` e sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster] -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a certificateRejected CertificateRejectRevoked = throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked) certificateRejected CertificateRejectExpired = throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired) certificateRejected CertificateRejectUnknownCA = throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa) certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) rejectOnException :: SomeException -> IO TLSCertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e 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 (commonCiphers == []) $ 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 , stCipher = 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 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 commonCiphers = intersect ciphers (map cipherID $ pCiphers params) usedCipher = fromJust $ find (\c -> cipherID c == head commonCiphers) (pCiphers params) 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 --- recvClientData = runRecvState ctx (RecvStateHandshake processClientCertificate) -- When the client sends a certificate, check whether -- it is acceptable for the application. -- processClientCertificate (Certificates certs) = -- Note that the following call will throw an -- exception when we did not request a certificate. -- withClientCertServer ctx $ \ ccp -> do -- Call application callback to see whether the -- certificate chain is acceptable. -- usage <- liftIO $ catch (onClientCertificate ccp certs) rejectOnException case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason -- 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 [CertVerify bs]) = withClientCertServer ctx $ \ ccp -> do dig <- usingState_ ctx $ getCertVerifyDigest -- Verify the signature. verif <- usingState_ ctx $ verifyRSA dig bs case verif of Right True -> return () _ -> 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. -- let arg = case verif of Left err -> Just err; _ -> Nothing res <- liftIO $ onUnverifiedClientCert ccp arg when (not res) $ do case verif of Left err -> throwCore $ Error_Protocol (show err, True, DecryptError) _ -> throwCore $ Error_Protocol ("verification failed", True, BadCertificate) return $ RecvStateNext expectChangeCipher processCertificateVerify p = 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") --- 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. -- case pClientCertParamsServer $ ctxParams ctx of Nothing -> return () Just ccp -> do let certTypes = [ CertificateType_RSA_Sign ] let creq = CertRequest certTypes Nothing (map extractCAname $ ccpCACertificates ccp) sendPacket ctx (Handshake [creq]) -- Send HelloDone sendPacket ctx (Handshake [ServerHelloDone]) extractCAname :: X509 -> DistinguishedName extractCAname cert = DistinguishedName $ certIssuerDN (x509Cert cert) handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello" -- after receiving a client hello, we need to redo a handshake 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) -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegotiation handshake :: MonadIO m => Context -> m () handshake ctx = do let handshakeF = case roleParams $ ctxParams ctx of Server sparams -> handshakeServer sparams Client cparams -> handshakeClient cparams liftIO $ handleException $ handshakeF ctx where handleException f = catch f $ \exception -> do let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception setEstablished ctx False sendPacket ctx (errorToAlert tlserror) handshakeFailed tlserror withClientCertServer :: MonadIO m => Context -> (ClientCertParamsServer -> m a) -> m a withClientCertServer ctx f = case pClientCertParamsServer $ ctxParams ctx of Nothing -> throwCore $ Error_Misc "client certificates not configured" Just cpp -> f cpp withClientCertClient :: MonadIO m => Context -> (ClientCertParamsClient -> m a) -> m a withClientCertClient ctx f = case pClientCertParamsClient $ ctxParams ctx of Nothing -> throwCore $ Error_Misc "client certificates not configured" Just cpp -> f cpp throwMiscErrorOnException :: MonadIO m => String -> SomeException -> m a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e