2010-09-09 21:47:19 +00:00
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.Receiving
|
|
|
|
-- 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
|
|
|
|
--
|
2013-07-09 06:15:54 +00:00
|
|
|
module Network.TLS.Receiving
|
|
|
|
( processHandshake
|
|
|
|
, processPacket
|
|
|
|
, processServerHello
|
|
|
|
, verifyRSA
|
|
|
|
) where
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-10-02 21:02:37 +00:00
|
|
|
import Control.Applicative ((<$>))
|
2010-09-09 21:47:19 +00:00
|
|
|
import Control.Monad.State
|
|
|
|
import Control.Monad.Error
|
|
|
|
|
2010-09-26 09:34:47 +00:00
|
|
|
import Data.ByteString (ByteString)
|
2011-12-05 20:10:28 +00:00
|
|
|
import qualified Data.ByteString as B
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-09-26 17:51:23 +00:00
|
|
|
import Network.TLS.Util
|
2010-09-09 21:47:19 +00:00
|
|
|
import Network.TLS.Struct
|
2011-08-12 17:41:49 +00:00
|
|
|
import Network.TLS.Record
|
2010-09-09 21:47:19 +00:00
|
|
|
import Network.TLS.Packet
|
|
|
|
import Network.TLS.State
|
|
|
|
import Network.TLS.Cipher
|
|
|
|
import Network.TLS.Crypto
|
2012-05-14 05:39:20 +00:00
|
|
|
import Network.TLS.Extension
|
2013-05-19 07:05:46 +00:00
|
|
|
import Data.X509
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
returnEither :: Either TLSError a -> TLSSt a
|
2010-09-09 21:47:19 +00:00
|
|
|
returnEither (Left err) = throwError err
|
|
|
|
returnEither (Right a) = return a
|
|
|
|
|
2011-08-12 17:41:49 +00:00
|
|
|
processPacket :: Record Plaintext -> TLSSt Packet
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-08-12 17:41:49 +00:00
|
|
|
processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment
|
2010-10-02 08:09:46 +00:00
|
|
|
|
2011-08-12 17:41:49 +00:00
|
|
|
processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment)
|
2010-10-02 08:09:46 +00:00
|
|
|
|
2011-08-12 17:41:49 +00:00
|
|
|
processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do
|
2013-07-09 06:19:16 +00:00
|
|
|
returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment
|
2013-07-11 08:03:33 +00:00
|
|
|
runRecordStateSt switchRxEncryption
|
2013-07-09 06:19:16 +00:00
|
|
|
return ChangeCipherSpec
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-08-12 17:41:49 +00:00
|
|
|
processPacket (Record ProtocolType_Handshake ver fragment) = do
|
2013-07-11 08:03:33 +00:00
|
|
|
keyxchg <- runRecordStateSt getCipherKeyExchangeType
|
2013-07-09 06:19:16 +00:00
|
|
|
npn <- getExtensionNPN
|
|
|
|
let currentparams = CurrentParams
|
|
|
|
{ cParamsVersion = ver
|
|
|
|
, cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg
|
|
|
|
, cParamsSupportNPN = npn
|
|
|
|
}
|
|
|
|
handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment)
|
|
|
|
hss <- forM handshakes $ \(ty, content) -> do
|
|
|
|
case decodeHandshake currentparams ty content of
|
|
|
|
Left err -> throwError err
|
|
|
|
Right hs -> return hs
|
|
|
|
return $ Handshake hss
|
2011-12-01 08:42:43 +00:00
|
|
|
|
2012-11-09 16:02:50 +00:00
|
|
|
processPacket (Record ProtocolType_DeprecatedHandshake _ fragment) =
|
2013-07-09 06:19:16 +00:00
|
|
|
case decodeDeprecatedHandshake $ fragmentGetBytes fragment of
|
|
|
|
Left err -> throwError err
|
|
|
|
Right hs -> return $ Handshake [hs]
|
2012-11-09 16:02:50 +00:00
|
|
|
|
2011-12-01 08:42:43 +00:00
|
|
|
processHandshake :: Handshake -> TLSSt ()
|
|
|
|
processHandshake hs = do
|
2013-07-09 06:19:16 +00:00
|
|
|
clientmode <- isClientContext
|
|
|
|
case hs of
|
|
|
|
ClientHello cver ran _ _ _ ex _ -> unless clientmode $ do
|
|
|
|
mapM_ processClientExtension ex
|
|
|
|
startHandshakeClient cver ran
|
|
|
|
Certificates certs -> processCertificates clientmode certs
|
|
|
|
ClientKeyXchg content -> unless clientmode $ do
|
|
|
|
processClientKeyXchg content
|
|
|
|
HsNextProtocolNegotiation selected_protocol ->
|
|
|
|
unless clientmode $ setNegotiatedProtocol selected_protocol
|
|
|
|
Finished fdata -> processClientFinished fdata
|
|
|
|
_ -> return ()
|
|
|
|
when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage $ encodeHandshake hs
|
|
|
|
when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs)
|
|
|
|
where -- secure renegotiation
|
|
|
|
processClientExtension (0xff01, content) = do
|
|
|
|
v <- getVerifiedData True
|
|
|
|
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 ()
|
2011-06-07 07:13:43 +00:00
|
|
|
|
2011-12-20 07:47:46 +00:00
|
|
|
decryptRSA :: ByteString -> TLSSt (Either KxError ByteString)
|
|
|
|
decryptRSA econtent = do
|
2013-07-11 08:03:33 +00:00
|
|
|
ver <- getRecordState stVersion
|
2013-07-09 06:19:16 +00:00
|
|
|
rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get
|
|
|
|
let cipher = if ver < TLS10 then econtent else B.drop 2 econtent
|
2013-07-11 08:03:33 +00:00
|
|
|
runRecordStateSt $ do
|
|
|
|
st <- get
|
|
|
|
let (mmsg,rng') = withTLSRNG (stRandomGen st) (\g -> kxDecrypt g rsapriv cipher)
|
|
|
|
put (st { stRandomGen = rng' })
|
|
|
|
return mmsg
|
2011-12-20 07:47:46 +00:00
|
|
|
|
2012-12-30 15:31:13 +00:00
|
|
|
verifyRSA :: HashDescr -> ByteString -> ByteString -> TLSSt Bool
|
2012-07-18 20:19:11 +00:00
|
|
|
verifyRSA hsh econtent sign = do
|
2013-07-09 06:19:16 +00:00
|
|
|
rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get
|
|
|
|
return $ kxVerify rsapriv hsh econtent sign
|
2012-07-13 19:08:23 +00:00
|
|
|
|
2011-12-20 07:46:40 +00:00
|
|
|
processServerHello :: Handshake -> TLSSt ()
|
|
|
|
processServerHello (ServerHello sver ran _ _ _ ex) = do
|
2013-07-09 06:19:16 +00:00
|
|
|
-- FIXME notify the user to take action if the extension requested is missing
|
|
|
|
-- secreneg <- getSecureRenegotiation
|
|
|
|
-- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ...
|
|
|
|
mapM_ processServerExtension ex
|
|
|
|
setServerRandom ran
|
|
|
|
setVersion sver
|
|
|
|
where processServerExtension (0xff01, content) = do
|
|
|
|
cv <- getVerifiedData True
|
|
|
|
sv <- getVerifiedData False
|
|
|
|
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 ()
|
2011-12-20 07:46:40 +00:00
|
|
|
processServerHello _ = error "processServerHello called on wrong type"
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-04-24 10:34:11 +00:00
|
|
|
-- process the client key exchange message. the protocol expects the initial
|
2012-03-10 21:04:44 +00:00
|
|
|
-- client version received in ClientHello, not the negotiated version.
|
2011-04-24 10:34:11 +00:00
|
|
|
-- in case the version mismatch, generate a random master secret
|
2011-12-01 08:41:01 +00:00
|
|
|
processClientKeyXchg :: ByteString -> TLSSt ()
|
|
|
|
processClientKeyXchg encryptedPremaster = do
|
2013-07-09 06:19:16 +00:00
|
|
|
expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get
|
2013-07-13 07:03:25 +00:00
|
|
|
random <- genRandom 48
|
2013-07-09 06:19:16 +00:00
|
|
|
ePremaster <- decryptRSA encryptedPremaster
|
|
|
|
case ePremaster of
|
|
|
|
Left _ -> setMasterSecretFromPre random
|
|
|
|
Right premaster -> case decodePreMasterSecret premaster of
|
|
|
|
Left _ -> setMasterSecretFromPre random
|
|
|
|
Right (ver, _)
|
|
|
|
| ver /= expectedVer -> setMasterSecretFromPre random
|
|
|
|
| otherwise -> setMasterSecretFromPre premaster
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
processClientFinished :: FinishedData -> TLSSt ()
|
2010-09-09 21:47:19 +00:00
|
|
|
processClientFinished fdata = do
|
2013-07-11 08:03:33 +00:00
|
|
|
cc <- isClientContext
|
2013-07-09 06:19:16 +00:00
|
|
|
expected <- getHandshakeDigest (not cc)
|
|
|
|
when (expected /= fdata) $ do
|
|
|
|
throwError $ Error_Protocol("bad record mac", True, BadRecordMac)
|
|
|
|
updateVerifiedData False fdata
|
|
|
|
return ()
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-05-19 07:05:46 +00:00
|
|
|
processCertificates :: Bool -> CertificateChain -> TLSSt ()
|
|
|
|
processCertificates False (CertificateChain []) = return ()
|
|
|
|
processCertificates True (CertificateChain []) =
|
|
|
|
throwError $ Error_Protocol ("server certificate missing", True, HandshakeFailure)
|
2013-05-30 06:21:25 +00:00
|
|
|
processCertificates clientmode (CertificateChain (c:_))
|
2013-07-19 06:47:54 +00:00
|
|
|
| clientmode = withHandshakeM $ setPublicKey pubkey
|
|
|
|
| otherwise = withHandshakeM $ setClientPublicKey pubkey
|
2013-05-30 06:21:25 +00:00
|
|
|
where pubkey = certPubKey $ getCertificate c
|