93 lines
3.9 KiB
Haskell
93 lines
3.9 KiB
Haskell
-- |
|
|
-- Module : Network.TLS.Handshake.Process
|
|
-- License : BSD-style
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
-- Stability : experimental
|
|
-- Portability : unknown
|
|
--
|
|
-- process handshake message received
|
|
--
|
|
module Network.TLS.Handshake.Process
|
|
( processHandshake
|
|
) where
|
|
|
|
import Data.ByteString (ByteString)
|
|
|
|
import Control.Monad (when, unless)
|
|
import Control.Monad.Error (throwError)
|
|
import Control.Monad.State (gets)
|
|
|
|
import Network.TLS.Types (Role(..), invertRole)
|
|
import Network.TLS.Util
|
|
import Network.TLS.Packet
|
|
import Network.TLS.Struct
|
|
import Network.TLS.State
|
|
import Network.TLS.Handshake.State
|
|
import Network.TLS.Handshake.Key
|
|
import Network.TLS.Extension
|
|
import Data.X509
|
|
|
|
processHandshake :: Handshake -> TLSSt ()
|
|
processHandshake hs = do
|
|
role <- isClientContext
|
|
case hs of
|
|
ClientHello cver ran _ _ _ ex _ -> when (role == ServerRole) $ do
|
|
mapM_ processClientExtension ex
|
|
startHandshakeClient cver ran
|
|
Certificates certs -> processCertificates role certs
|
|
ClientKeyXchg content -> when (role == ServerRole) $ do
|
|
processClientKeyXchg content
|
|
HsNextProtocolNegotiation selected_protocol ->
|
|
when (role == ServerRole) $ setNegotiatedProtocol selected_protocol
|
|
Finished fdata -> processClientFinished fdata
|
|
_ -> return ()
|
|
let encoded = encodeHandshake hs
|
|
when (certVerifyHandshakeMaterial hs) $ withHandshakeM $ addHandshakeMessage encoded
|
|
when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ withHandshakeM $ updateHandshakeDigest encoded
|
|
where -- secure renegotiation
|
|
processClientExtension (0xff01, content) = do
|
|
v <- getVerifiedData ClientRole
|
|
let bs = extensionEncode (SecureRenegotiation v Nothing)
|
|
unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure)
|
|
|
|
setSecureRenegotiation True
|
|
-- unknown extensions
|
|
processClientExtension _ = return ()
|
|
|
|
-- process the client key exchange message. the protocol expects the initial
|
|
-- client version received in ClientHello, not the negotiated version.
|
|
-- in case the version mismatch, generate a random master secret
|
|
processClientKeyXchg :: ByteString -> TLSSt ()
|
|
processClientKeyXchg encryptedPremaster = do
|
|
rver <- getVersion
|
|
role <- isClientContext
|
|
random <- genRandom 48
|
|
ePremaster <- decryptRSA encryptedPremaster
|
|
withHandshakeM $ do
|
|
expectedVer <- gets hstClientVersion
|
|
case ePremaster of
|
|
Left _ -> setMasterSecretFromPre rver role random
|
|
Right premaster -> case decodePreMasterSecret premaster of
|
|
Left _ -> setMasterSecretFromPre rver role random
|
|
Right (ver, _)
|
|
| ver /= expectedVer -> setMasterSecretFromPre rver role random
|
|
| otherwise -> setMasterSecretFromPre rver role premaster
|
|
|
|
processClientFinished :: FinishedData -> TLSSt ()
|
|
processClientFinished fdata = do
|
|
cc <- isClientContext
|
|
ver <- getVersion
|
|
expected <- withHandshakeM $ getHandshakeDigest ver $ invertRole cc
|
|
when (expected /= fdata) $ do
|
|
throwError $ Error_Protocol("bad record mac", True, BadRecordMac)
|
|
updateVerifiedData ServerRole fdata
|
|
return ()
|
|
|
|
processCertificates :: Role -> CertificateChain -> TLSSt ()
|
|
processCertificates ServerRole (CertificateChain []) = return ()
|
|
processCertificates ClientRole (CertificateChain []) =
|
|
throwError $ Error_Protocol ("server certificate missing", True, HandshakeFailure)
|
|
processCertificates role (CertificateChain (c:_))
|
|
| role == ClientRole = withHandshakeM $ setPublicKey pubkey
|
|
| otherwise = withHandshakeM $ setClientPublicKey pubkey
|
|
where pubkey = certPubKey $ getCertificate c
|