2012-08-18 22:05:56 +00:00
|
|
|
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
|
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.Handshake.Client
|
|
|
|
-- License : BSD-style
|
|
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : unknown
|
|
|
|
--
|
|
|
|
module Network.TLS.Handshake.Client
|
|
|
|
( handshakeClient
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Network.TLS.Crypto
|
|
|
|
import Network.TLS.Context
|
|
|
|
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.Measurement
|
|
|
|
import Network.TLS.Wire (encodeWord16)
|
2013-11-27 07:08:22 +00:00
|
|
|
import Network.TLS.Util (bytesEq, catchException)
|
2013-07-22 06:54:35 +00:00
|
|
|
import Network.TLS.Types
|
2013-05-30 06:21:25 +00:00
|
|
|
import Network.TLS.X509
|
2012-08-18 22:05:56 +00:00
|
|
|
import Data.Maybe
|
|
|
|
import Data.List (find)
|
|
|
|
import qualified Data.ByteString as B
|
|
|
|
import Data.ByteString.Char8 ()
|
|
|
|
|
2013-08-01 07:12:54 +00:00
|
|
|
import Control.Applicative ((<$>), (<*>))
|
2012-08-18 22:05:56 +00:00
|
|
|
import Control.Monad.State
|
2013-07-24 05:50:56 +00:00
|
|
|
import Control.Monad.Error
|
2012-08-19 22:14:58 +00:00
|
|
|
import Control.Exception (SomeException)
|
2012-08-18 22:05:56 +00:00
|
|
|
|
|
|
|
import Network.TLS.Handshake.Common
|
2013-08-01 07:24:18 +00:00
|
|
|
import Network.TLS.Handshake.Process
|
2012-08-18 22:05:56 +00:00
|
|
|
import Network.TLS.Handshake.Certificate
|
|
|
|
import Network.TLS.Handshake.Signature
|
2013-07-28 08:19:28 +00:00
|
|
|
import Network.TLS.Handshake.Key
|
2013-07-20 06:18:16 +00:00
|
|
|
import Network.TLS.Handshake.State
|
2012-08-18 22:05:56 +00:00
|
|
|
|
|
|
|
-- client part of handshake. send a bunch of handshake of client
|
|
|
|
-- values intertwined with response from the server.
|
2013-08-01 07:52:42 +00:00
|
|
|
handshakeClient :: ClientParams -> Context -> IO ()
|
2012-08-18 22:05:56 +00:00
|
|
|
handshakeClient cparams ctx = do
|
2012-10-20 07:56:53 +00:00
|
|
|
updateMeasure ctx incrementNbHandshakes
|
|
|
|
sentExtensions <- sendClientHello
|
|
|
|
recvServerHello sentExtensions
|
|
|
|
sessionResuming <- usingState_ ctx isSessionResuming
|
|
|
|
if sessionResuming
|
2013-07-23 07:14:48 +00:00
|
|
|
then sendChangeCipherAndFinish ctx ClientRole
|
2012-10-20 07:56:53 +00:00
|
|
|
else do sendClientData cparams ctx
|
2013-07-23 07:14:48 +00:00
|
|
|
sendChangeCipherAndFinish ctx ClientRole
|
2012-10-20 07:56:53 +00:00
|
|
|
recvChangeCipherAndFinish ctx
|
|
|
|
handshakeTerminate ctx
|
2013-07-10 06:20:58 +00:00
|
|
|
where params = ctxParams ctx
|
|
|
|
ciphers = pCiphers params
|
|
|
|
compressions = pCompressions params
|
|
|
|
getExtensions = sequence [sniExtension,secureReneg,npnExtention] >>= return . catMaybes
|
|
|
|
|
|
|
|
toExtensionRaw :: Extension e => e -> ExtensionRaw
|
|
|
|
toExtensionRaw ext = (extensionID ext, extensionEncode ext)
|
|
|
|
|
|
|
|
secureReneg =
|
|
|
|
if pUseSecureRenegotiation params
|
2013-07-24 05:50:56 +00:00
|
|
|
then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing
|
2013-07-10 06:20:58 +00:00
|
|
|
else return Nothing
|
|
|
|
npnExtention = if isJust $ onNPNServerSuggest cparams
|
|
|
|
then return $ Just $ toExtensionRaw $ NextProtocolNegotiation []
|
|
|
|
else return Nothing
|
|
|
|
sniExtension = return ((\h -> toExtensionRaw $ ServerName [(ServerNameHostName h)]) <$> clientUseServerName cparams)
|
|
|
|
sendClientHello = do
|
|
|
|
crand <- getStateRNG ctx 32 >>= return . ClientRandom
|
|
|
|
let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams
|
|
|
|
extensions <- getExtensions
|
2013-08-01 07:24:18 +00:00
|
|
|
startHandshake ctx (pConnectVersion params) crand
|
2013-12-03 07:17:27 +00:00
|
|
|
usingState_ ctx $ setVersionIfUnset (pConnectVersion params)
|
2013-07-10 06:20:58 +00:00
|
|
|
sendPacket ctx $ Handshake
|
|
|
|
[ ClientHello (pConnectVersion params) crand clientSession (map cipherID ciphers)
|
|
|
|
(map compressionID compressions) extensions Nothing
|
|
|
|
]
|
|
|
|
return $ map fst extensions
|
|
|
|
|
2013-07-29 06:19:13 +00:00
|
|
|
recvServerHello sentExts = runRecvState ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts)
|
2012-08-18 22:05:56 +00:00
|
|
|
|
2012-08-19 22:14:58 +00:00
|
|
|
-- | send client Data after receiving all server data (hello/certificates/key).
|
|
|
|
--
|
|
|
|
-- -> [certificate]
|
|
|
|
-- -> client key exchange
|
|
|
|
-- -> [cert verify]
|
2013-08-01 07:52:42 +00:00
|
|
|
sendClientData :: ClientParams -> Context -> IO ()
|
2012-08-19 22:14:58 +00:00
|
|
|
sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify
|
2013-07-10 06:20:58 +00:00
|
|
|
where
|
|
|
|
-- 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
|
2013-07-20 06:18:16 +00:00
|
|
|
certRequested <- usingHState ctx getClientCertRequest
|
2013-07-10 06:20:58 +00:00
|
|
|
case certRequested of
|
|
|
|
Nothing ->
|
|
|
|
return ()
|
|
|
|
|
|
|
|
Just req -> do
|
2013-11-27 07:08:22 +00:00
|
|
|
certChain <- liftIO $ onCertificateRequest cparams req `catchException`
|
2013-07-10 06:20:58 +00:00
|
|
|
throwMiscErrorOnException "certificate request callback failed"
|
|
|
|
|
2013-07-20 06:18:16 +00:00
|
|
|
usingHState ctx $ setClientCertSent False
|
2013-07-10 06:20:58 +00:00
|
|
|
case certChain of
|
|
|
|
Nothing -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])]
|
|
|
|
Just (CertificateChain [], _) -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])]
|
|
|
|
Just (cc@(CertificateChain (c:_)), pk) -> do
|
|
|
|
case certPubKey $ getCertificate c of
|
|
|
|
PubKeyRSA _ -> return ()
|
|
|
|
_ -> throwCore $ Error_Protocol ("no supported certificate type", True, HandshakeFailure)
|
2013-07-19 06:47:54 +00:00
|
|
|
usingHState ctx $ setClientPrivateKey pk
|
2013-07-20 06:18:16 +00:00
|
|
|
usingHState ctx $ setClientCertSent True
|
2013-07-10 06:20:58 +00:00
|
|
|
sendPacket ctx $ Handshake [Certificates cc]
|
|
|
|
|
|
|
|
sendClientKeyXchg = do
|
2013-12-03 07:17:27 +00:00
|
|
|
clientVersion <- usingHState ctx $ gets hstClientVersion
|
2013-08-01 07:12:54 +00:00
|
|
|
(xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46
|
2013-12-03 07:17:27 +00:00
|
|
|
let premaster = encodePreMasterSecret clientVersion prerand
|
2013-08-01 07:12:54 +00:00
|
|
|
usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
|
2013-08-01 07:35:42 +00:00
|
|
|
encryptedPreMaster <- do
|
2013-07-10 06:20:58 +00:00
|
|
|
-- SSL3 implementation generally forget this length field since it's redundant,
|
|
|
|
-- however TLS10 make it clear that the length field need to be present.
|
2013-08-01 07:35:42 +00:00
|
|
|
e <- encryptRSA ctx premaster
|
2013-07-10 06:20:58 +00:00
|
|
|
let extra = if xver < TLS10
|
|
|
|
then B.empty
|
|
|
|
else encodeWord16 $ fromIntegral $ B.length e
|
|
|
|
return $ extra `B.append` e
|
|
|
|
sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster]
|
|
|
|
|
|
|
|
-- 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
|
2013-07-25 20:53:32 +00:00
|
|
|
usedVersion <- usingState_ ctx getVersion
|
2013-07-10 06:20:58 +00:00
|
|
|
|
|
|
|
-- Only send a certificate verify message when we
|
|
|
|
-- have sent a non-empty list of certificates.
|
2012-08-19 22:14:58 +00:00
|
|
|
--
|
2013-07-20 06:18:16 +00:00
|
|
|
certSent <- usingHState ctx $ getClientCertSent
|
2013-07-10 06:20:58 +00:00
|
|
|
case certSent of
|
2013-07-20 06:18:16 +00:00
|
|
|
True -> do
|
2012-08-19 22:14:58 +00:00
|
|
|
|
2013-12-07 05:10:17 +00:00
|
|
|
malg <- case usedVersion of
|
|
|
|
TLS12 -> do
|
2013-07-20 06:18:16 +00:00
|
|
|
Just (_, Just hashSigs, _) <- usingHState ctx $ getClientCertRequest
|
2013-07-10 06:20:58 +00:00
|
|
|
let suppHashSigs = pHashSignatures $ ctxParams ctx
|
|
|
|
hashSigs' = filter (\ a -> a `elem` hashSigs) suppHashSigs
|
2012-08-19 22:14:58 +00:00
|
|
|
|
2013-12-07 05:10:17 +00:00
|
|
|
when (null hashSigs') $
|
2013-07-10 06:20:58 +00:00
|
|
|
throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure)
|
2013-12-07 05:10:17 +00:00
|
|
|
return $ Just $ head hashSigs'
|
|
|
|
_ -> return Nothing
|
2012-08-19 22:14:58 +00:00
|
|
|
|
2013-12-07 05:10:17 +00:00
|
|
|
-- Fetch all handshake messages up to now.
|
|
|
|
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
|
|
|
|
(hashMethod, toSign) <- prepareCertificateVerifySignatureData ctx usedVersion malg msgs
|
2012-08-19 22:14:58 +00:00
|
|
|
|
2013-12-07 04:44:45 +00:00
|
|
|
sigDig <- signRSA ctx hashMethod toSign
|
|
|
|
sendPacket ctx $ Handshake [CertVerify malg (CertVerifyData sigDig)]
|
2012-08-19 22:14:58 +00:00
|
|
|
|
2013-07-10 06:20:58 +00:00
|
|
|
_ -> return ()
|
2012-08-18 22:05:56 +00:00
|
|
|
|
2013-07-28 14:22:17 +00:00
|
|
|
processServerExtension :: (ExtensionID, Bytes) -> TLSSt ()
|
|
|
|
processServerExtension (0xff01, content) = do
|
|
|
|
cv <- getVerifiedData ClientRole
|
|
|
|
sv <- getVerifiedData ServerRole
|
|
|
|
let bs = extensionEncode (SecureRenegotiation cv $ Just sv)
|
|
|
|
unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)
|
|
|
|
return ()
|
|
|
|
processServerExtension _ = return ()
|
2012-08-18 22:05:56 +00:00
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
throwMiscErrorOnException :: String -> SomeException -> IO a
|
2012-08-18 22:05:56 +00:00
|
|
|
throwMiscErrorOnException msg e =
|
2013-07-10 06:20:58 +00:00
|
|
|
throwCore $ Error_Misc $ msg ++ ": " ++ show e
|
2013-07-29 06:19:13 +00:00
|
|
|
|
|
|
|
-- | onServerHello process the ServerHello message on the client.
|
|
|
|
--
|
|
|
|
-- 1) check the version chosen by the server is one allowed by parameters.
|
|
|
|
-- 2) check that our compression and cipher algorithms are part of the list we sent
|
|
|
|
-- 3) check extensions received are part of the one we sent
|
|
|
|
-- 4) process the session parameter to see if the server want to start a new session or can resume
|
|
|
|
-- 5) process NPN extension
|
|
|
|
-- 6) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher
|
|
|
|
--
|
2013-08-01 07:52:42 +00:00
|
|
|
onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO)
|
2013-07-29 06:19:13 +00:00
|
|
|
onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do
|
|
|
|
when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
|
|
|
|
case find ((==) rver) allowedvers of
|
2013-11-29 10:44:44 +00:00
|
|
|
Nothing -> throwCore $ Error_Protocol ("server version " ++ show rver ++ " is not supported", True, ProtocolVersion)
|
2013-12-03 07:17:27 +00:00
|
|
|
Just _ -> return ()
|
2013-07-29 06:19:13 +00:00
|
|
|
-- find the compression and cipher methods that the server want to use.
|
2013-12-03 07:17:27 +00:00
|
|
|
cipherAlg <- case find ((==) cipher . cipherID) ciphers of
|
|
|
|
Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure)
|
|
|
|
Just alg -> return alg
|
|
|
|
compressAlg <- case find ((==) compression . compressionID) compressions of
|
|
|
|
Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, HandshakeFailure)
|
|
|
|
Just alg -> return alg
|
2013-07-29 06:19:13 +00:00
|
|
|
|
|
|
|
-- intersect sent extensions in client and the received extensions from server.
|
|
|
|
-- if server returns extensions that we didn't request, fail.
|
|
|
|
when (not $ null $ filter (not . flip elem sentExts . fst) exts) $
|
|
|
|
throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension)
|
|
|
|
|
|
|
|
let resumingSession =
|
|
|
|
case clientWantSessionResume cparams of
|
|
|
|
Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing
|
|
|
|
Nothing -> Nothing
|
|
|
|
usingState_ ctx $ do
|
|
|
|
setSession serverSession (isJust resumingSession)
|
|
|
|
mapM_ processServerExtension exts
|
|
|
|
setVersion rver
|
2013-12-03 07:17:27 +00:00
|
|
|
usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg
|
2013-07-29 06:19:13 +00:00
|
|
|
|
|
|
|
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 ctx)
|
|
|
|
Just sessionData -> do
|
|
|
|
usingHState ctx (setMasterSecret rver ClientRole $ sessionSecret sessionData)
|
|
|
|
return $ RecvStateNext expectChangeCipher
|
|
|
|
where params = ctxParams ctx
|
|
|
|
allowedvers = pAllowedVersions params
|
|
|
|
ciphers = pCiphers params
|
|
|
|
compressions = pCompressions params
|
|
|
|
onServerHello _ _ _ p = unexpected (show p) (Just "server hello")
|
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
processCertificate :: Context -> Handshake -> IO (RecvState IO)
|
2013-07-29 06:19:13 +00:00
|
|
|
processCertificate ctx (Certificates certs) = do
|
2013-11-27 07:08:22 +00:00
|
|
|
usage <- liftIO $ catchException (onCertificatesRecv params certs) rejectOnException
|
2013-07-29 06:19:13 +00:00
|
|
|
case usage of
|
|
|
|
CertificateUsageAccept -> return ()
|
|
|
|
CertificateUsageReject reason -> certificateRejected reason
|
|
|
|
return $ RecvStateHandshake (processServerKeyExchange ctx)
|
|
|
|
where params = ctxParams ctx
|
|
|
|
processCertificate ctx p = processServerKeyExchange ctx p
|
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
expectChangeCipher :: Packet -> IO (RecvState IO)
|
2013-07-29 06:19:13 +00:00
|
|
|
expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
|
|
|
|
expectChangeCipher p = unexpected (show p) (Just "change cipher")
|
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
expectFinish :: Handshake -> IO (RecvState IO)
|
2013-07-29 06:19:13 +00:00
|
|
|
expectFinish (Finished _) = return RecvStateDone
|
|
|
|
expectFinish p = unexpected (show p) (Just "Handshake Finished")
|
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
|
2013-07-29 06:19:13 +00:00
|
|
|
processServerKeyExchange ctx (ServerKeyXchg _) = return $ RecvStateHandshake (processCertificateRequest ctx)
|
|
|
|
processServerKeyExchange ctx p = processCertificateRequest ctx p
|
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
|
2013-07-29 06:19:13 +00:00
|
|
|
processCertificateRequest ctx (CertRequest cTypes sigAlgs dNames) = do
|
|
|
|
-- When the server requests a client
|
|
|
|
-- certificate, we simply store the
|
|
|
|
-- information for later.
|
|
|
|
--
|
|
|
|
usingHState ctx $ setClientCertRequest (cTypes, sigAlgs, dNames)
|
|
|
|
return $ RecvStateHandshake (processServerHelloDone ctx)
|
|
|
|
processCertificateRequest ctx p = processServerHelloDone ctx p
|
|
|
|
|
2013-08-01 07:52:42 +00:00
|
|
|
processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
|
2013-07-29 06:19:13 +00:00
|
|
|
processServerHelloDone _ ServerHelloDone = return RecvStateDone
|
|
|
|
processServerHelloDone _ p = unexpected (show p) (Just "server hello data")
|