From 5a6ff3abe8073301d51ef479afafa72817d4c798 Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Sat, 2 Oct 2010 10:34:45 +0100
Subject: [PATCH] take in account that we can receive multiple handshakes in
 the same tls fragment.

---
 Network/TLS/Packet.hs    | 19 +++++++++++++------
 Network/TLS/Receiving.hs | 11 +++++++++--
 Tests.hs                 |  2 +-
 3 files changed, 23 insertions(+), 9 deletions(-)

diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs
index f427007..87583f9 100644
--- a/Network/TLS/Packet.hs
+++ b/Network/TLS/Packet.hs
@@ -20,7 +20,7 @@ module Network.TLS.Packet
 	, encodeAlert
 
 	-- * marshall functions for handshake messages
-	, decodeHandshakeHeader
+	, decodeHandshakes
 	, decodeHandshake
 	, encodeHandshake
 	, encodeHandshakeHeader
@@ -90,19 +90,26 @@ encodeAlert :: (AlertLevel, AlertDescription) -> ByteString
 encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad))
 
 {- decode and encode HANDSHAKE -}
-
-decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, Bytes)
-decodeHandshakeHeader = runGet $ do
+decodeHandshakeHeader :: Get (HandshakeType, Bytes)
+decodeHandshakeHeader = do
 	tyopt <- getWord8 >>= return . valToType
 	ty <- if isNothing tyopt
 		then throwError (Error_Unknown_Type "handshake type")
 		else return $ fromJust tyopt
 	len <- getWord24
 	content <- getBytes len
-	empty <- isEmpty
-	unless empty (throwError (Error_Internal_Packet_Remaining 1))
 	return (ty, content)
 
+decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)]
+decodeHandshakes b = runGet getAll b
+	where
+		getAll = do
+			x <- decodeHandshakeHeader
+			empty <- isEmpty
+			if empty
+				then return [x]
+				else getAll >>= \l -> return (x : l)
+
 decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake
 decodeHandshake ver ty = runGet $ case ty of
 	HandshakeType_HelloRequest    -> decodeHelloRequest
diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs
index 80d713c..5960bfd 100644
--- a/Network/TLS/Receiving.hs
+++ b/Network/TLS/Receiving.hs
@@ -69,7 +69,15 @@ processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
 	return ChangeCipherSpec
 
 processPacket (Header ProtocolType_Handshake ver _) dcontent = do
-	(ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent
+	handshakes <- returnEither (decodeHandshakes dcontent)
+	hss <- forM handshakes $ \(ty, content) -> do
+		hs <- processHandshake ver ty content
+		when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content
+		return hs
+	return $ head hss -- FIXME for compat until we fixes the expectations in server/client
+
+processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet
+processHandshake ver ty econtent = do
 	-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.
 	content <- case ty of
 		HandshakeType_ClientKeyXchg -> do
@@ -93,7 +101,6 @@ processPacket (Header ProtocolType_Handshake ver _) dcontent = do
 			processClientKeyXchg cver content
 		Finished fdata               -> processClientFinished fdata
 		_                            -> return ()
-	when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent)
 	return $ Handshake hs
 
 decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)
diff --git a/Tests.hs b/Tests.hs
index b5be240..0aa7914 100644
--- a/Tests.hs
+++ b/Tests.hs
@@ -89,7 +89,7 @@ instance Arbitrary Handshake where
 prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x
 prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x
 	where
-		decodeHs b = either (Left . id) (\(ty, bdata) -> decodeHandshake TLS10 ty bdata) $ decodeHandshakeHeader b
+		decodeHs b = either (Left . id) (uncurry (decodeHandshake TLS10) . head) $ decodeHandshakes b
 
 {- main -}
 args = Args