new state machine

Network/TLS/Receiving.hs

@@ -14,6 +14,7 @@ module Network.TLS.Receiving (
 	readPacket
 	) where
 
+import Control.Applicative ((<$>))
 import Control.Monad.State
 import Control.Monad.Error
 import Data.Maybe
@@ -54,7 +55,21 @@ returnEither (Left err) = throwError err
 returnEither (Right a)  = return a
 
 readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet)
-readPacket hdr content = runTLSRead (decryptContent hdr content >>= processPacket hdr)
+readPacket hdr content = runTLSRead (checkState hdr >> decryptContent hdr content >>= processPacket hdr)
+
+checkState :: Header -> TLSRead ()
+checkState (Header pt _ _) =
+		stStatus <$> getTLSState >>= \status -> unless (allowed pt status) $ throwError $ Error_Packet_unexpected (show status) (show pt)
+	where
+		allowed :: ProtocolType -> TLSStatus -> Bool
+		allowed ProtocolType_Alert _                    = True
+		allowed ProtocolType_Handshake _                = True
+		allowed ProtocolType_AppData StatusHandshakeReq = True
+		allowed ProtocolType_AppData StatusOk           = True
+		allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientFinished) = True
+		allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientKeyXchg) = True
+		allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True
+		allowed _ _ = False
 
 processPacket :: Header -> Bytes -> TLSRead Packet
 
@@ -63,6 +78,9 @@ processPacket (Header ProtocolType_AppData _ _) content = return $ AppData conte
 processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlert content)
 
 processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
+	e <- updateStatusCC False
+	when (isJust e) $ throwError (fromJust e)
+
 	returnEither $ decodeChangeCipherSpec content
 	switchRxEncryption
 	isClientContext >>= \cc -> when (not cc) setKeyBlock
@@ -79,6 +97,9 @@ processPacket (Header ProtocolType_Handshake ver _) dcontent = do
 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.
+	e <- updateStatusHs ty
+	when (isJust e) $ throwError (fromJust e)
+
 	content <- case ty of
 		HandshakeType_ClientKeyXchg -> do
 			copt <- decryptRSA econtent

Network/TLS/Sending.hs

@@ -76,13 +76,24 @@ postprocessPacketData dat = return dat
 encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString
 encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]
 
+{-
+ - just update TLS state machine
+ -}
+preProcessPacket :: MonadTLSState m => Packet -> m Packet
+preProcessPacket pkt = do
+	e <- case pkt of
+		Handshake hs     -> updateStatusHs (typeOfHandshake hs)
+		AppData _        -> return Nothing
+		ChangeCipherSpec -> updateStatusCC True
+		Alert _          -> return Nothing
+	return pkt
 
 {-
  - writePacket transform a packet into marshalled data related to current state
  - and updating state on the go
  -}
 writePacket :: MonadTLSState m => Packet -> m ByteString
-writePacket pkt = makePacketData pkt >>= processPacketData >>=
+writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>=
                   encryptPacketData >>= postprocessPacketData >>= encodePacket
 
 {------------------------------------------------------------------------------}

Network/TLS/State.hs

@@ -18,6 +18,8 @@ module Network.TLS.State
 	, MonadTLSState, getTLSState, putTLSState, modifyTLSState
 	, newTLSState
 	, assert -- FIXME move somewhere else (Internal.hs ?)
+	, updateStatusHs
+	, updateStatusCC
 	, finishHandshakeTypeMaterial
 	, finishHandshakeMaterial
 	, makeDigest
@@ -39,6 +41,7 @@ module Network.TLS.State
 	) where
 
 import Data.Word
+import Data.List (find)
 import Data.Maybe (fromJust, isNothing)
 import Network.TLS.Util
 import Network.TLS.Struct
@@ -67,7 +70,6 @@ data HandshakeStatus =
 	| HsStatusClientChangeCipher
 	| HsStatusClientFinished
 	| HsStatusServerChangeCipher
-	| HsStatusServerFinished
 	deriving (Show,Eq)
 
 data TLSStatus =
@@ -154,6 +156,68 @@ makeDigest w hdr content = do
 	modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })
 	return digest
 
+hsStatusTransitionTable :: [ (HandshakeType, TLSStatus, [ TLSStatus ]) ]
+hsStatusTransitionTable =
+	[ (HandshakeType_HelloRequest, StatusHandshakeReq,
+		[ StatusOk ])
+	, (HandshakeType_ClientHello, StatusHandshake HsStatusClientHello,
+		[ StatusInit, StatusHandshakeReq ])
+	, (HandshakeType_ServerHello, StatusHandshake HsStatusServerHello,
+		[ StatusHandshake HsStatusClientHello ])
+	, (HandshakeType_Certificate, StatusHandshake HsStatusServerCertificate,
+		[ StatusHandshake HsStatusServerHello ])
+	, (HandshakeType_ServerKeyXchg, StatusHandshake HsStatusServerKeyXchg,
+		[ StatusHandshake HsStatusServerHello
+		, StatusHandshake HsStatusServerCertificate ])
+	, (HandshakeType_CertRequest, StatusHandshake HsStatusServerCertificateReq,
+		[ StatusHandshake HsStatusServerHello
+		, StatusHandshake HsStatusServerCertificate
+		, StatusHandshake HsStatusServerKeyXchg ])
+	, (HandshakeType_ServerHelloDone, StatusHandshake HsStatusServerHelloDone,
+		[ StatusHandshake HsStatusServerHello
+		, StatusHandshake HsStatusServerCertificate
+		, StatusHandshake HsStatusServerKeyXchg
+		, StatusHandshake HsStatusServerCertificateReq ])
+	, (HandshakeType_Certificate, StatusHandshake HsStatusClientCertificate,
+		[ StatusHandshake HsStatusServerHelloDone ])
+	, (HandshakeType_ClientKeyXchg, StatusHandshake HsStatusClientKeyXchg,
+		[ StatusHandshake HsStatusServerHelloDone
+		, StatusHandshake HsStatusClientCertificate ])
+	, (HandshakeType_CertVerify, StatusHandshake HsStatusClientCertificateVerify,
+		[ StatusHandshake HsStatusClientKeyXchg ])
+	, (HandshakeType_Finished, StatusHandshake HsStatusClientFinished,
+		[ StatusHandshake HsStatusClientChangeCipher ])
+	, (HandshakeType_Finished, StatusOk,
+		[ StatusHandshake HsStatusServerChangeCipher ])
+	]
+
+updateStatus :: MonadTLSState m => TLSStatus -> m ()
+updateStatus x = modifyTLSState (\st -> st { stStatus = x })
+
+updateStatusHs :: MonadTLSState m => HandshakeType -> m (Maybe TLSError)
+updateStatusHs ty = do
+	status <- return . stStatus =<< getTLSState
+	ns <- return . transition . stStatus =<< getTLSState
+	case ns of
+		Nothing      -> return $ Just $ Error_Packet_unexpected (show status) ("handshake:" ++ show ty)
+		Just (_,x,_) -> updateStatus x >> return Nothing
+	where
+		edgeEq cur (ety, _, aprevs) = ty == ety && (maybe False (const True) $ find (== cur) aprevs)
+		transition currentStatus = find (edgeEq currentStatus) hsStatusTransitionTable
+
+updateStatusCC :: MonadTLSState m => Bool -> m (Maybe TLSError)
+updateStatusCC sending = do
+	status <- return . stStatus =<< getTLSState
+	cc     <- isClientContext
+	let x = case (cc /= sending, status) of
+		(False, StatusHandshake HsStatusClientKeyXchg)           -> Just (StatusHandshake HsStatusClientChangeCipher)
+		(False, StatusHandshake HsStatusClientCertificateVerify) -> Just (StatusHandshake HsStatusClientChangeCipher)
+		(True, StatusHandshake HsStatusClientFinished)           -> Just (StatusHandshake HsStatusServerChangeCipher)
+		_                                                        -> Nothing
+	case x of
+		Just newstatus -> updateStatus newstatus >> return Nothing
+		Nothing        -> return $ Just $ Error_Packet_unexpected (show status) ("Client Context: " ++ show cc)
+
 finishHandshakeTypeMaterial :: HandshakeType -> Bool
 finishHandshakeTypeMaterial HandshakeType_ClientHello     = True
 finishHandshakeTypeMaterial HandshakeType_ServerHello     = True

Network/TLS/Struct.hs

@@ -103,6 +103,7 @@ data TLSError =
 	| Error_Digest ([Word8], [Word8])
 	| Error_Packet String
 	| Error_Packet_Size_Mismatch (Int, Int)
+	| Error_Packet_unexpected String String
 	| Error_Internal_Packet_Remaining Int
 	| Error_Internal_Packet_ByteProcessed Int Int Int
 	| Error_Unknown_Version Word8 Word8