95 lines
4 KiB
Haskell
95 lines
4 KiB
Haskell
|
-- |
|
||
|
-- Module : Network.TLS.Handshake.Process
|
||
|
-- License : BSD-style
|
||
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
||
|
-- Stability : experimental
|
||
|
-- Portability : unknown
|
||
|
--
|
||
|
-- the Receiving module contains calls related to unmarshalling packets according
|
||
|
-- to the TLS state
|
||
|
--
|
||
|
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
|