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
|
|
|
|
--
|
2012-07-13 19:08:23 +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
|
2010-09-09 21:47:19 +00:00
|
|
|
import Data.Certificate.X509
|
|
|
|
|
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
|
2012-03-27 07:57:51 +00:00
|
|
|
returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment
|
|
|
|
switchRxEncryption
|
|
|
|
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
|
2012-03-27 07:57:51 +00:00
|
|
|
keyxchg <- getCipherKeyExchangeType
|
2012-11-19 09:39:35 +00:00
|
|
|
npn <- getExtensionNPN
|
2012-03-27 07:57:51 +00:00
|
|
|
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) =
|
|
|
|
case decodeDeprecatedHandshake $ fragmentGetBytes fragment of
|
|
|
|
Left err -> throwError err
|
|
|
|
Right hs -> return $ Handshake [hs]
|
|
|
|
|
2011-12-01 08:42:43 +00:00
|
|
|
processHandshake :: Handshake -> TLSSt ()
|
|
|
|
processHandshake hs = do
|
2012-03-27 07:57:51 +00:00
|
|
|
clientmode <- isClientContext
|
|
|
|
case hs of
|
2012-11-09 16:02:50 +00:00
|
|
|
ClientHello cver ran _ _ _ ex _ -> unless clientmode $ do
|
2012-03-27 07:57:51 +00:00
|
|
|
mapM_ processClientExtension ex
|
|
|
|
startHandshakeClient cver ran
|
2012-07-13 19:33:45 +00:00
|
|
|
Certificates certs -> processCertificates clientmode certs
|
2012-03-27 07:57:51 +00:00
|
|
|
ClientKeyXchg content -> unless clientmode $ do
|
|
|
|
processClientKeyXchg content
|
2012-05-14 05:35:55 +00:00
|
|
|
HsNextProtocolNegotiation selected_protocol ->
|
2012-02-08 09:20:28 +00:00
|
|
|
unless clientmode $ do
|
2012-02-12 18:59:19 +00:00
|
|
|
setNegotiatedProtocol selected_protocol
|
2012-03-27 07:57:51 +00:00
|
|
|
Finished fdata -> processClientFinished fdata
|
|
|
|
_ -> return ()
|
2012-07-26 20:46:59 +00:00
|
|
|
when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage $ encodeHandshake hs
|
2012-03-27 07:57:51 +00:00
|
|
|
when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs)
|
|
|
|
where
|
|
|
|
-- secure renegotiation
|
|
|
|
processClientExtension (0xff01, content) = do
|
|
|
|
v <- getVerifiedData True
|
2012-05-14 05:39:20 +00:00
|
|
|
let bs = extensionEncode (SecureRenegotiation v Nothing)
|
2012-05-14 05:32:14 +00:00
|
|
|
unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure)
|
2012-05-14 05:39:20 +00:00
|
|
|
|
2012-03-27 07:57:51 +00:00
|
|
|
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
|
2012-03-27 07:57:51 +00:00
|
|
|
ver <- stVersion <$> get
|
|
|
|
rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get
|
|
|
|
return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent)
|
2011-12-20 07:47:46 +00:00
|
|
|
|
2012-07-26 21:06:08 +00:00
|
|
|
verifyRSA :: (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> TLSSt (Either KxError Bool)
|
2012-07-18 20:19:11 +00:00
|
|
|
verifyRSA hsh econtent sign = do
|
2012-07-13 19:08:23 +00:00
|
|
|
rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get
|
2012-07-18 20:19:11 +00:00
|
|
|
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
|
2012-03-27 07:57:51 +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
|
2012-05-14 05:39:20 +00:00
|
|
|
let bs = extensionEncode (SecureRenegotiation cv $ Just sv)
|
2012-05-14 05:32:14 +00:00
|
|
|
unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)
|
2012-03-27 07:57:51 +00:00
|
|
|
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
|
2012-03-27 07:57:51 +00:00
|
|
|
expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get
|
|
|
|
random <- genTLSRandom 48
|
|
|
|
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
|
2012-03-27 07:57:51 +00:00
|
|
|
cc <- stClientContext <$> get
|
|
|
|
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
|
|
|
|
2012-07-13 19:33:45 +00:00
|
|
|
processCertificates :: Bool -> [X509] -> TLSSt ()
|
|
|
|
processCertificates clientmode certs = do
|
2012-11-09 16:02:50 +00:00
|
|
|
if null certs
|
2012-07-13 20:29:36 +00:00
|
|
|
then when (clientmode) $
|
|
|
|
throwError $ Error_Protocol ("server certificate missing", True,
|
|
|
|
HandshakeFailure)
|
|
|
|
else do
|
|
|
|
let (X509 mainCert _ _ _ _) = head certs
|
|
|
|
case certPubKey mainCert of
|
2012-07-13 19:33:45 +00:00
|
|
|
PubKeyRSA pubkey -> (if clientmode
|
|
|
|
then setPublicKey
|
|
|
|
else setClientPublicKey) (PubRSA pubkey)
|
2012-03-27 07:57:51 +00:00
|
|
|
_ -> return ()
|